;;; smtp.el --- basic functions to send mail with SMTP server
-;; Copyright (C) 1995, 1996, 1998 Free Software Foundation, Inc.
+;; Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc.
;; Author: Tomoji Kagatani <kagatani@rbc.ncl.omron.co.jp>
-;; Simon Leinen <simon@switch.ch> (ESMTP support)
-;; Shuhei KOBAYASHI <shuhei-k@jaist.ac.jp>
+;; Simon Leinen <simon@switch.ch> (ESMTP support)
+;; Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp>
+;; Daiki Ueno <ueno@unixuser.org>
;; Keywords: SMTP, mail
;; This file is part of FLIM (Faithful Library about Internet Message).
;; General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; along with this program; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Code:
-(require 'mail-utils) ; pick up mail-strip-quoted-names
+(require 'poe)
+(require 'poem)
+(require 'pcustom)
+(require 'mail-utils) ; mail-strip-quoted-names
+
+(eval-when-compile (require 'cl)) ; push
+
+(require 'tram)
+
+(eval-and-compile
+ (luna-define-class smtp-stream (tram-stream)
+ (process
+ extensions))
+
+ (luna-define-internal-accessors 'smtp-stream))
(defgroup smtp nil
"SMTP protocol for sending mail."
:group 'mail)
(defcustom smtp-default-server nil
- "*Specify default SMTP server."
+ "Specify default SMTP server."
:type '(choice (const nil) string)
:group 'smtp)
(defcustom smtp-server (or (getenv "SMTPSERVER") smtp-default-server)
- "*The name of the host running SMTP server. It can also be a function
+ "The name of the host running SMTP server. It can also be a function
called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS."
:type '(choice (string :tag "Name")
(function :tag "Function"))
:group 'smtp)
(defcustom smtp-service "smtp"
- "*SMTP service port number. \"smtp\" or 25."
+ "SMTP service port number. \"smtp\" or 25."
:type '(choice (integer :tag "25" 25)
(string :tag "smtp" "smtp"))
:group 'smtp)
(defcustom smtp-use-8bitmime t
- "*If non-nil, use ESMTP 8BITMIME if available."
+ "If non-nil, use ESMTP 8BITMIME if available."
:type 'boolean
:group 'smtp)
(defcustom smtp-local-domain nil
- "*Local domain name without a host name.
+ "Local domain name without a host name.
If the function (system-name) returns the full internet address,
don't define this value."
:type '(choice (const nil) string)
:group 'smtp)
-(defvar smtp-debug-info nil)
+(defcustom smtp-notify-success nil
+ "If non-nil, notification for successful mail delivery is returned
+ to user (RFC1891)."
+ :type 'boolean
+ :group 'smtp)
+
+(defvar smtp-transaction-compose-function
+ #'smtp-default-transaction-compose-function)
+
+(defvar smtp-open-connection-function (function open-network-stream))
+
(defvar smtp-read-point nil)
(defun smtp-make-fqdn ()
(t
(error "Cannot generate valid FQDN. Set `smtp-local-domain' correctly.")))))
+(defun smtp-greeting (trans)
+ (let ((response
+ (smtp-read-response
+ (smtp-stream-process-internal trans))))
+ (or (smtp-check-response response)
+ (tram-stream-error trans 'greeting))
+ trans))
+
+(defun smtp-ehlo (trans)
+ (smtp-send-command
+ (smtp-stream-process-internal trans)
+ (format "EHLO %s" (smtp-make-fqdn)))
+ (let ((response
+ (smtp-read-response
+ (smtp-stream-process-internal trans))))
+ (or (smtp-check-response response)
+ (tram-stream-error trans 'ehlo))
+ (smtp-stream-set-extensions-internal
+ trans (mapcar
+ (lambda (extension)
+ (car (read-from-string (downcase extension))))
+ (cdr response)))
+ trans))
+
+(defun smtp-helo (trans)
+ (smtp-send-command
+ (smtp-stream-process-internal trans)
+ (format "HELO %s" (smtp-make-fqdn)))
+ (let ((response
+ (smtp-read-response
+ (smtp-stream-process-internal trans))))
+ (or (smtp-check-response response)
+ (tram-stream-error trans 'helo))
+ trans))
+
+(defun smtp-mailfrom (sender trans)
+ (smtp-send-command
+ (smtp-stream-process-internal trans)
+ (format "MAIL FROM:<%s>%s"
+ sender
+ ;; SIZE --- Message Size Declaration (RFC1870)
+;;; (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-stream-extensions-internal trans))
+ smtp-use-8bitmime)
+ " BODY=8BITMIME"
+ "")))
+ (let ((response
+ (smtp-read-response
+ (smtp-stream-process-internal trans))))
+ (or (smtp-check-response response)
+ (tram-stream-error trans 'mailfrom))
+ trans))
+
+(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))
+
+(defun smtp-data (buffer trans)
+ (smtp-send-command
+ (smtp-stream-process-internal trans)
+ "DATA")
+ (let ((response
+ (smtp-read-response
+ (smtp-stream-process-internal trans))))
+ (or (smtp-check-response response)
+ (tram-stream-error trans 'data))
+
+ ;; Mail contents
+ (smtp-send-data
+ (smtp-stream-process-internal trans)
+ buffer)
+ ;; DATA end "."
+ (smtp-send-command
+ (smtp-stream-process-internal trans)
+ ".")
+ (setq response
+ (smtp-read-response
+ (smtp-stream-process-internal trans)))
+ (or (smtp-check-response response)
+ (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)
smtp-server))
- process response extensions)
+ process response extensions trans error)
(save-excursion
(set-buffer
(get-buffer-create
(format "*trace of SMTP session to %s*" server)))
+ (buffer-disable-undo)
(erase-buffer)
(make-local-variable 'smtp-read-point)
(setq smtp-read-point (point-min))
-
(unwind-protect
- (catch 'done
- (setq process (open-network-stream-as-binary
- "SMTP" (current-buffer) server smtp-service))
- (or process (throw 'done nil))
-
- (set-process-filter process 'smtp-process-filter)
-
- ;; Greeting
- (setq response (smtp-read-response process))
- (if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
- (throw 'done (car (cdr response))))
-
- ;; EHLO
- (smtp-send-command process
- (format "EHLO %s" (smtp-make-fqdn)))
- (setq response (smtp-read-response process))
- (if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
- (progn
- ;; HELO
- (smtp-send-command process
- (format "HELO %s" (smtp-make-fqdn)))
- (setq response (smtp-read-response process))
- (if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
- (throw 'done (car (cdr response)))))
- (let ((extension-lines (cdr (cdr response))))
- (while extension-lines
- (push (intern (downcase (substring (car extension-lines) 4)))
- extensions)
- (setq extension-lines (cdr extension-lines)))))
-
- ;; ONEX --- One message transaction only (sendmail extension?)
- (if (or (memq 'onex extensions)
- (memq 'xone extensions))
- (progn
- (smtp-send-command process "ONEX")
- (setq response (smtp-read-response process))
- (if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
- (throw 'done (car (cdr response))))))
-
- ;; VERB --- Verbose (sendmail extension?)
- (if (and smtp-debug-info
- (or (memq 'verb extensions)
- (memq 'xvrb extensions)))
- (progn
- (smtp-send-command process "VERB")
- (setq response (smtp-read-response process))
- (if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
- (throw 'done (car (cdr response))))))
-
- ;; XUSR --- Initial (user) submission (sendmail extension?)
- (if (memq 'xusr extensions)
- (progn
- (smtp-send-command process "XUSR")
- (setq response (smtp-read-response process))
- (if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
- (throw 'done (car (cdr response))))))
-
- ;; MAIL FROM:<sender>
- (smtp-send-command
- process
- (format "MAIL FROM:<%s>%s%s"
- sender
- ;; SIZE --- Message Size Declaration (RFC1870)
- (if (memq 'size extensions)
- (format " SIZE=%d"
- (save-excursion
- (set-buffer smtp-text-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 extensions)
- smtp-use-8bitmime)
- " BODY=8BITMIME"
- "")))
- (setq response (smtp-read-response process))
- (if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
- (throw 'done (car (cdr response))))
-
- ;; RCPT TO:<recipient>
- (while recipients
- (smtp-send-command process
- (format "RCPT TO:<%s>" (car recipients)))
- (setq recipients (cdr recipients))
- (setq response (smtp-read-response process))
- (if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
- (throw 'done (car (cdr response)))))
-
- ;; DATA
- (smtp-send-command process "DATA")
- (setq response (smtp-read-response process))
- (if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
- (throw 'done (car (cdr response))))
-
- ;; Mail contents
- (smtp-send-data process smtp-text-buffer)
-
- ;; DATA end "."
- (smtp-send-command process ".")
- (setq response (smtp-read-response process))
- (if (or (null (car response))
- (not (integerp (car response)))
- (>= (car response) 400))
- (throw 'done (car (cdr response))))
-
- t)
-
- (if (and process
- (eq (process-status process) 'open))
- (progn
- ;; QUIT
- (smtp-send-command process "QUIT")
- (smtp-read-response process)
- (delete-process process)))))))
+ (let ((function
+ (funcall smtp-transaction-compose-function
+ sender recipients smtp-text-buffer)))
+ (or (functionp function)
+ (error "Unable to compose SMTP commands"))
+ (if (eq (car-safe function) 'lambda)
+ (setq function (byte-compile function)))
+ (as-binary-process
+ (setq process
+ (funcall smtp-open-connection-function
+ "SMTP" (current-buffer) server smtp-service)))
+ (when process
+ (set-process-filter process 'smtp-process-filter)
+ (setq trans
+ (luna-make-entity 'smtp-stream :process process)
+ error
+ (catch (tram-stream-error-name trans)
+ (funcall function trans)
+ nil))
+ (not error)))
+ (when (and process
+ (memq (process-status process) '(open run)))
+ ;; QUIT
+ (smtp-send-command process "QUIT")
+ (delete-process process))))))
(defun smtp-process-filter (process output)
(save-excursion
(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)
+ (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) ?.)
(defun smtp-deduce-address-list (smtp-text-buffer header-start header-end)
"Get address list suitable for smtp RCPT TO:<address>."
- (let ((case-fold-search t)
- (simple-address-list "")
+ (let ((simple-address-list "")
this-line
this-line-end
addr-regexp
(save-excursion
;;
(set-buffer smtp-address-buffer)
+ (setq case-fold-search t)
(erase-buffer)
(insert (save-excursion
(set-buffer smtp-text-buffer)
projects / elisp / flim.git / blobdiff