(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 '(choice (const nil) string)
:group 'smtp)
-(defcustom smtp-debug-info nil
- "*smtp debug info printout. messages and process buffer."
- :type 'boolean
- :group 'smtp)
-
(defcustom smtp-notify-success nil
"If non-nil, notification for successful mail delivery is returned
to user (RFC1891)."
: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 trans (cdr response))
+ (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
(defun smtp-read-response (process)
(let ((case-fold-search nil)
- (response-strings nil)
+ response
(response-continue t)
- (return-value '(nil ()))
match-end)
-
(while response-continue
(goto-char smtp-read-point)
(while (not (search-forward "\r\n" nil t))
(accept-process-output process)
(goto-char smtp-read-point))
-
(setq match-end (point))
- (setq response-strings
- (cons (buffer-substring smtp-read-point (- match-end 2))
- response-strings))
-
+ (setq response
+ (nconc response
+ (list (buffer-substring (+ 4 smtp-read-point)
+ (- match-end 2)))))
(goto-char smtp-read-point)
- (if (looking-at "[0-9]+ ")
- (let ((begin (match-beginning 0))
- (end (match-end 0)))
- (if smtp-debug-info
- (message "%s" (car response-strings)))
-
- (setq smtp-read-point match-end)
-
- ;; ignore lines that start with "0"
- (if (looking-at "0[0-9]+ ")
- nil
- (setq response-continue nil)
- (setq return-value
- (cons (string-to-int
- (buffer-substring begin end))
- (nreverse response-strings)))))
-
- (if (looking-at "[0-9]+-")
- (progn (if smtp-debug-info
- (message "%s" (car response-strings)))
- (setq smtp-read-point match-end)
- (setq response-continue t))
- (progn
- (setq smtp-read-point match-end)
- (setq response-continue nil)
- (setq return-value
- (cons nil (nreverse response-strings)))))))
- (setq smtp-read-point match-end)
- return-value))
+ (when (looking-at "[1-5][0-9][0-9] ")
+ (setq response-continue nil)
+ (push (read (point-marker)) response))
+ (setq smtp-read-point match-end))
+ response))
(defun smtp-check-response (response)
- (> (car response) 200))
+ (memq (/ (car response) 100) '(2 3)));; XXX
(defun smtp-send-command (process command)
(goto-char (point-max))
(defun smtp-send-data-1 (process data)
(goto-char (point-max))
- (if smtp-debug-info
- (insert data "\r\n"))
(setq smtp-read-point (point))
;; Escape "." at start of a line.
(if (eq (string-to-char data) ?.)
projects / elisp / flim.git / blobdiff