(eval-when-compile (require 'cl)) ; push
-(require 'net-trans)
+(require 'tram)
(eval-and-compile
- (luna-define-class smtp-transaction (net-transaction)
+ (luna-define-class smtp-stream (tram-stream)
(process
- extensions
- sender
- recipients
- buffer))
+ extensions))
- (luna-define-internal-accessors 'smtp-transaction))
+ (luna-define-internal-accessors 'smtp-stream))
(defgroup smtp nil
"SMTP protocol for sending mail."
:type 'boolean
:group 'smtp)
-(defvar smtp-open-connection-function (function open-network-stream))
-
-(defvar smtp-default-commands
- '(&& smtp-greeting (|| smtp-ehlo smtp-helo)
- smtp-mailfrom smtp-rcptto smtp-data))
+(defvar smtp-transaction-compose-function
+ #'smtp-default-transaction-compose-function)
-(defvar smtp-commands smtp-default-commands)
+(defvar smtp-open-connection-function (function open-network-stream))
(defvar smtp-read-point nil)
-(defvar smtp-transaction-function nil)
-
(defun smtp-make-fqdn ()
"Return user's fully qualified domain name."
(let ((system-name (system-name)))
(t
(error "Cannot generate valid FQDN. Set `smtp-local-domain' correctly.")))))
-(luna-define-generic smtp-greeting (trans))
-(luna-define-generic smtp-ehlo (trans))
-(luna-define-generic smtp-helo (trans))
-(luna-define-generic smtp-mailfrom (trans))
-(luna-define-generic smtp-rcptto (trans))
-(luna-define-generic smtp-data (trans))
-
-(luna-define-method smtp-greeting ((trans smtp-transaction))
+(defun smtp-greeting (trans)
(let ((response
(smtp-read-response
- (smtp-transaction-process-internal trans))))
+ (smtp-stream-process-internal trans))))
(or (smtp-check-response response)
- (net-transaction-error trans 'greeting))
+ (tram-stream-error trans 'greeting))
trans))
-(luna-define-method smtp-ehlo ((trans smtp-transaction))
+(defun smtp-ehlo (trans)
(smtp-send-command
- (smtp-transaction-process-internal trans)
+ (smtp-stream-process-internal trans)
(format "EHLO %s" (smtp-make-fqdn)))
(let ((response
(smtp-read-response
- (smtp-transaction-process-internal trans))))
+ (smtp-stream-process-internal trans))))
(or (smtp-check-response response)
- (net-transaction-error trans 'ehlo))
- (smtp-transaction-set-extensions-internal
+ (tram-stream-error trans 'ehlo))
+ (smtp-stream-set-extensions-internal
trans (mapcar
(lambda (extension)
(car (read-from-string (downcase extension))))
(cdr response)))
trans))
-(luna-define-method smtp-helo ((trans smtp-transaction))
+(defun smtp-helo (trans)
(smtp-send-command
- (smtp-transaction-process-internal trans)
+ (smtp-stream-process-internal trans)
(format "HELO %s" (smtp-make-fqdn)))
(let ((response
(smtp-read-response
- (smtp-transaction-process-internal trans))))
+ (smtp-stream-process-internal trans))))
(or (smtp-check-response response)
- (net-transaction-error trans 'helo))
+ (tram-stream-error trans 'helo))
trans))
-(luna-define-method smtp-mailfrom ((trans smtp-transaction))
+(defun smtp-mailfrom (sender trans)
(smtp-send-command
- (smtp-transaction-process-internal trans)
- (format "MAIL FROM:<%s>%s%s"
- (smtp-transaction-sender-internal trans)
+ (smtp-stream-process-internal trans)
+ (format "MAIL FROM:<%s>%s"
+ sender
;; SIZE --- Message Size Declaration (RFC1870)
- (if (memq 'size
- (smtp-transaction-extensions-internal trans))
- (format " SIZE=%d"
- (save-excursion
- (set-buffer
- (smtp-transaction-buffer-internal trans))
- (+ (- (point-max) (point-min))
- ;; Add one byte for each change-of-line
- ;; because or CR-LF representation:
- (count-lines (point-min) (point-max))
- ;; For some reason, an empty line is
- ;; added to the message. Maybe this
- ;; is a bug, but it can't hurt to add
- ;; those two bytes anyway:
- 2)))
- "")
+;;; (if (memq 'size
+;;; (smtp-stream-extensions-internal trans))
+;;; (format " SIZE=%d"
+;;; (save-excursion
+;;; (set-buffer buffer)
+;;; (+ (- (point-max) (point-min))
+;;; ;; Add one byte for each change-of-line
+;;; ;; because or CR-LF representation:
+;;; (count-lines (point-min) (point-max))
+;;; ;; For some reason, an empty line is
+;;; ;; added to the message. Maybe this
+;;; ;; is a bug, but it can't hurt to add
+;;; ;; those two bytes anyway:
+;;; 2)))
+;;; "")
;; 8BITMIME --- 8bit-MIMEtransport (RFC1652)
(if (and (memq '8bitmime
- (smtp-transaction-extensions-internal trans))
+ (smtp-stream-extensions-internal trans))
smtp-use-8bitmime)
" BODY=8BITMIME"
"")))
(let ((response
(smtp-read-response
- (smtp-transaction-process-internal trans))))
+ (smtp-stream-process-internal trans))))
(or (smtp-check-response response)
- (net-transaction-error trans 'mailfrom))
+ (tram-stream-error trans 'mailfrom))
trans))
-(luna-define-method smtp-rcptto ((trans smtp-transaction))
- (let ((recipients
- (smtp-transaction-recipients-internal trans))
- response)
- (while recipients
- (smtp-send-command
- (smtp-transaction-process-internal trans)
- (format
- (if smtp-notify-success
- "RCPT TO:<%s> NOTIFY=SUCCESS"
- "RCPT TO:<%s>")
- (car recipients)))
- (setq response
- (smtp-read-response
- (smtp-transaction-process-internal trans)))
- (or (smtp-check-response response)
- (net-transaction-error trans 'rcptto))
- (setq recipients (cdr recipients)))
+(defun smtp-rcptto (recipient trans)
+ (let (response)
+ (smtp-send-command
+ (smtp-stream-process-internal trans)
+ (format
+ (if smtp-notify-success
+ "RCPT TO:<%s> NOTIFY=SUCCESS"
+ "RCPT TO:<%s>")
+ recipient))
+ (setq response
+ (smtp-read-response
+ (smtp-stream-process-internal trans)))
+ (or (smtp-check-response response)
+ (tram-stream-error trans 'rcptto))
trans))
-(luna-define-method smtp-data ((trans smtp-transaction))
+(defun smtp-data (buffer trans)
(smtp-send-command
- (smtp-transaction-process-internal trans)
+ (smtp-stream-process-internal trans)
"DATA")
(let ((response
(smtp-read-response
- (smtp-transaction-process-internal trans))))
+ (smtp-stream-process-internal trans))))
(or (smtp-check-response response)
- (net-transaction-error trans 'data))
+ (tram-stream-error trans 'data))
;; Mail contents
(smtp-send-data
- (smtp-transaction-process-internal trans)
- (smtp-transaction-buffer-internal trans))
-
+ (smtp-stream-process-internal trans)
+ buffer)
;; DATA end "."
(smtp-send-command
- (smtp-transaction-process-internal trans)
+ (smtp-stream-process-internal trans)
".")
(setq response
(smtp-read-response
- (smtp-transaction-process-internal trans)))
+ (smtp-stream-process-internal trans)))
(or (smtp-check-response response)
- (net-transaction-error trans 'data))
+ (tram-stream-error trans 'data))
trans))
+(defun smtp-default-transaction-compose-function (sender recipients buffer)
+ (tram-compose-transaction
+ `(&& smtp-greeting
+ (|| smtp-ehlo smtp-helo)
+ ,(closure-partial-call #'smtp-mailfrom sender)
+ ,@(mapcar
+ (lambda (recipient)
+ (closure-partial-call #'smtp-rcptto recipient))
+ recipients)
+ ,(closure-partial-call #'smtp-data buffer))))
+
(defun smtp-via-smtp (sender recipients smtp-text-buffer)
(let ((server (if (functionp smtp-server)
(funcall smtp-server sender recipients)
(erase-buffer)
(make-local-variable 'smtp-read-point)
(setq smtp-read-point (point-min))
- (make-local-variable 'smtp-transaction-function)
- (or smtp-transaction-function
- (let ((function (net-transaction-compose-commands smtp-commands)))
+ (unwind-protect
+ (let ((function
+ (funcall smtp-transaction-compose-function
+ sender recipients smtp-text-buffer)))
(or (functionp function)
(error "Unable to compose SMTP commands"))
- (setq smtp-transaction-function function)))
- (unwind-protect
- (progn
+ (if (eq (car-safe function) 'lambda)
+ (setq function (byte-compile function)))
(as-binary-process
(setq process
(funcall smtp-open-connection-function
(when process
(set-process-filter process 'smtp-process-filter)
(setq trans
- (luna-make-entity 'smtp-transaction
- :process process
- :sender sender
- :recipients recipients
- :buffer smtp-text-buffer)
+ (luna-make-entity 'smtp-stream :process process)
error
- (catch (net-transaction-error-name trans)
- (funcall smtp-transaction-function trans)
+ (catch (tram-stream-error-name trans)
+ (funcall function trans)
nil))
(not error)))
(when (and process
response))
(defun smtp-check-response (response)
- (= (/ (car response) 100) 2))
+ (memq (/ (car response) 100) '(2 3)));; XXX
(defun smtp-send-command (process command)
(goto-char (point-max))