X-Git-Url: http://git.chise.org/gitweb/?p=elisp%2Fflim.git;a=blobdiff_plain;f=smtp.el;h=3704d46c44009761a136bcc86a030227f7f007ac;hp=25b5f72d2ab9e075912b373bcfeb65319623707e;hb=6ef1daccd72054e60d0ef6f87bb052982340f49c;hpb=57a3177465e8d977a8b2423f4343eefd3adf3d00 diff --git a/smtp.el b/smtp.el index 25b5f72..3704d46 100644 --- a/smtp.el +++ b/smtp.el @@ -1,6 +1,7 @@ ;;; smtp.el --- basic functions to send mail with SMTP server -;; Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001 ,2002, 2004 +;; Free Software Foundation, Inc. ;; Author: Tomoji Kagatani ;; Simon Leinen (ESMTP support) @@ -22,12 +23,12 @@ ;; You should have received a copy of the GNU General Public License ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: -;; +;; ;;; Code: @@ -35,6 +36,7 @@ (require 'mail-utils) ; mail-strip-quoted-names (require 'sasl) (require 'luna) +(require 'mel) ; binary-funcall (defgroup smtp nil "SMTP protocol for sending mail." @@ -57,10 +59,16 @@ called from `smtp-via-smtp' with arguments SENDER and RECIPIENTS." (function :tag "Function")) :group 'smtp) +(defcustom smtp-send-by-myself nil + "If non-nil, smtp.el send a mail by myself without smtp-server. +This option requires \"dig.el\"." + :type 'boolean + :group 'smtp) + (defcustom smtp-service "smtp" "SMTP service port number. \"smtp\" or 25." :type '(choice (integer :tag "25" 25) - (string :tag "smtp" "smtp")) + (string :tag "smtp" "smtp")) :group 'smtp) (defcustom smtp-local-domain nil @@ -90,6 +98,19 @@ don't define this value." :type 'boolean :group 'smtp-extensions) +(defcustom smtp-use-starttls-ignore-error nil + "If non-nil, do not use STARTTLS if STARTTLS is not available." + :type 'boolean + :group 'smtp-extensions) + +(defcustom smtp-starttls-program "starttls" + "The program to run in a subprocess to open an TLSv1 connection." + :group 'smtp-extensions) + +(defcustom smtp-starttls-extra-args nil + "Extra arguments to `starttls-program'" + :group 'smtp-extensions) + (defcustom smtp-use-sasl nil "If non-nil, use SMTP Authentication (RFC2554) if available." :type 'boolean @@ -110,10 +131,43 @@ don't define this value." :type '(repeat string) :group 'smtp-extensions) +(defcustom smtp-progress-message-format nil + "Format string used to show progress message while sending mails. +It allows the following special format specifiers: + +%b means show the number of bytes which has been sent + and the total bytes of a mail. +%k means show the number of kilobytes which has been sent + and the total kilobytes of a mail. +%l means show the number of lines which has been sent + and the total lines of a mail. + +For instance, the value \"Sending (%k)...\" shows like +\"Sending (45k/123k)...\" in the echo area." + :type '(radio (string :format "%v\n" :size 0 :value "Sending (%k)...") + (const :tag "Don't show progress message" nil)) + :group 'smtp) + (defvar sasl-mechanisms) -(autoload 'binary-open-network-stream "raw-io") -(defvar smtp-open-connection-function #'binary-open-network-stream) +;;;###autoload +(defvar smtp-open-connection-function #'open-network-stream + "*Function used for connecting to a SMTP server. +The function will be called with the same four arguments as +`open-network-stream' and should return a process object. +Here is an example: + +\(setq smtp-open-connection-function + #'(lambda (name buffer host service) + (let ((process-connection-type nil)) + (start-process name buffer \"ssh\" \"-C\" host + \"nc\" host service)))) + +It connects to a SMTP server using \"ssh\" before actually connecting +to the SMTP port. Where the command \"nc\" is the netcat executable; +see http://www.atstake.com/research/tools/index.html#network_utilities +for details. In addition, you will have to modify the value for +`smtp-end-of-line' to \"\\n\" if you use \"telnet\" instead of \"nc\".") (defvar smtp-read-point nil) @@ -121,6 +175,11 @@ don't define this value." (defvar smtp-submit-package-function #'smtp-submit-package) +(defvar smtp-end-of-line "\r\n" + "*String to use as end-of-line marker when talking to a SMTP server. +This is \"\\r\\n\" by default, but it may have to be \"\\n\" when using a non +native connection function. See also `smtp-open-connection-function'.") + ;;; @ SMTP package ;;; A package contains a mail message, an envelope sender address, ;;; and one or more envelope recipient addresses. In ESMTP model @@ -235,8 +294,8 @@ Return a newly allocated connection-object. BUFFER is the buffer to associate with the connection. SERVER is name of the host to connect to. SERVICE is name of the service desired." (let ((process - (funcall smtp-open-connection-function - "SMTP" buffer server service)) + (binary-funcall smtp-open-connection-function + "SMTP" buffer server service)) connection) (when process (setq connection (smtp-make-connection process server service)) @@ -246,8 +305,54 @@ of the host to connect to. SERVICE is name of the service desired." smtp-connection-alist)) connection))) +(eval-and-compile + (autoload 'dig-invoke "dig") + (autoload 'dig-extract-rr "dig")) + +(defun smtp-find-mx (domain &optional doerror) + (let (server) + ;; dig.el resolves only primally MX. + (cond ((setq server (smtp-dig domain "MX")) + (progn (string-match " \\([^ ]*\\)$" server) + (match-string 1 server))) + ((smtp-dig domain "A") + domain) + (t + (if doerror + (error (format "SMTP cannot resolve %s" domain))))))) + +(defun smtp-dig (domain type) + (let (dig-buf) + (set-buffer + (setq dig-buf (dig-invoke domain type))) + (prog1 + (dig-extract-rr domain type) + (kill-buffer dig-buf)))) + +(defun smtp-find-server (recipients) + (save-excursion + (let ((rec + (mapcar (lambda (recipient) + (let (server) + (if (and (string-match "@\\([^\t\n ]*\\)" recipient) + (setq server + (smtp-find-mx + (match-string 1 recipient)))) + (cons server (list recipient)) + (error (format "cannot find server for %s." recipient))))) + recipients)) + ret rets rlist) + (while (setq rets (pop rec)) + (if (setq ret (assoc (car rets) rec)) + (setcdr ret + (append (cdr ret) (cdr rets))) + (setq rlist + (append rlist (list rets))))) + rlist))) + ;;;###autoload (defun smtp-via-smtp (sender recipients buffer) + "Like `smtp-send-buffer', but sucks in any errors." (condition-case nil (progn (smtp-send-buffer sender recipients buffer) @@ -258,27 +363,36 @@ of the host to connect to. SERVICE is name of the service desired." ;;;###autoload (defun smtp-send-buffer (sender recipients buffer) - (let ((server - (if (functionp smtp-server) - (funcall smtp-server sender recipients) - smtp-server)) - (package - (smtp-make-package sender recipients buffer)) - (smtp-open-connection-function - (if smtp-use-starttls - #'starttls-open-stream - smtp-open-connection-function))) - (save-excursion - (set-buffer - (get-buffer-create - (format "*trace of SMTP session to %s*" server))) - (erase-buffer) - (buffer-disable-undo) - (unless (smtp-find-connection (current-buffer)) - (smtp-open-connection (current-buffer) server smtp-service)) - (make-local-variable 'smtp-read-point) - (setq smtp-read-point (point-min)) - (funcall smtp-submit-package-function package)))) + "Send a message. +SENDER is an envelope sender address. +RECIPIENTS is a list of envelope recipient addresses. +BUFFER may be a buffer or a buffer name which contains mail message." + (if smtp-send-by-myself + (smtp-send-buffer-by-myself sender recipients buffer) + (let* ((server + (if (functionp smtp-server) + (funcall smtp-server sender recipients) + (or smtp-server + (error "`smtp-server' not defined")))) + (package + (smtp-make-package sender recipients buffer)) + (starttls-program smtp-starttls-program) + (starttls-extra-args smtp-starttls-extra-args) + (smtp-open-connection-function + (if smtp-use-starttls + #'starttls-open-stream + smtp-open-connection-function))) + (save-excursion + (set-buffer + (get-buffer-create + (format "*trace of SMTP session to %s*" server))) + (erase-buffer) + (buffer-disable-undo) + (unless (smtp-find-connection (current-buffer)) + (smtp-open-connection (current-buffer) server smtp-service)) + (make-local-variable 'smtp-read-point) + (setq smtp-read-point (point-min)) + (funcall smtp-submit-package-function package))))) (defun smtp-submit-package (package) (unwind-protect @@ -289,7 +403,14 @@ of the host to connect to. SERVICE is name of the service desired." (smtp-response-error (smtp-primitive-helo package))) (if smtp-use-starttls - (smtp-primitive-starttls package)) + (if (assq 'starttls + (smtp-connection-extensions-internal + (smtp-find-connection (current-buffer)))) + (progn + (smtp-primitive-starttls package) + (smtp-primitive-ehlo package)) + (unless smtp-use-starttls-ignore-error + (error "STARTTLS is not supported on this server")))) (if smtp-use-sasl (smtp-primitive-auth package)) (smtp-primitive-mailfrom package) @@ -300,6 +421,42 @@ of the host to connect to. SERVICE is name of the service desired." (smtp-primitive-quit package) (smtp-close-connection connection))))) +(defun smtp-send-buffer-by-myself (sender recipients buffer) + "Send a message by myself. +SENDER is an envelope sender address. +RECIPIENTS is a list of envelope recipient addresses. +BUFFER may be a buffer or a buffer name which contains mail message." + (let ((servers + (smtp-find-server recipients)) + (smtp-open-connection-function + (if smtp-use-starttls + #'starttls-open-stream + smtp-open-connection-function)) + server package) + (while (car servers) + (setq server (caar servers)) + (setq recipients (cdar servers)) + (if (not (and server recipients)) + ;; MAILER-DAEMON is required. :) + (error (format "Cannot send <%s>" + (mapconcat 'concat recipients ">,<")))) + (setq package + (smtp-make-package sender recipients buffer)) + (save-excursion + (set-buffer + (get-buffer-create + (format "*trace of SMTP session to %s*" server))) + (erase-buffer) + (buffer-disable-undo) + (unless (smtp-find-connection (current-buffer)) + (smtp-open-connection (current-buffer) server smtp-service)) + (make-local-variable 'smtp-read-point) + (setq smtp-read-point (point-min)) + (let ((smtp-use-sasl nil) + (smtp-use-starttls-ignore-error t)) + (funcall smtp-submit-package-function package))) + (setq servers (cdr servers))))) + ;;; @ hook methods for `smtp-submit-package' ;;; @@ -444,18 +601,20 @@ of the host to connect to. SERVICE is name of the service desired." (defun smtp-primitive-data (package) (let* ((connection (smtp-find-connection (current-buffer))) - response) + response def prev) (smtp-send-command connection "DATA") (setq response (smtp-read-response connection)) (if (/= (car response) 354) (smtp-response-error response)) (save-excursion (set-buffer (smtp-package-buffer-internal package)) + (setq def (smtp-parse-progress-message-format)) (goto-char (point-min)) (while (not (eobp)) (smtp-send-data connection (buffer-substring (point) (progn (end-of-line)(point)))) - (beginning-of-line 2))) + (beginning-of-line 2) + (setq prev (smtp-show-progress-message def prev)))) (smtp-send-command connection ".") (setq response (smtp-read-response connection)) (if (/= (car response) 250) @@ -494,13 +653,13 @@ of the host to connect to. SERVICE is name of the service desired." response) (while response-continue (goto-char smtp-read-point) - (while (not (search-forward "\r\n" nil t)) + (while (not (search-forward smtp-end-of-line nil t)) (accept-process-output (smtp-connection-process-internal connection)) (goto-char smtp-read-point)) (if decoder (let ((string (buffer-substring smtp-read-point (- (point) 2)))) (delete-region smtp-read-point (point)) - (insert (funcall decoder string) "\r\n"))) + (insert (funcall decoder string) smtp-end-of-line))) (setq response (nconc response (list (buffer-substring @@ -522,7 +681,7 @@ of the host to connect to. SERVICE is name of the service desired." (smtp-connection-encoder-internal connection))) (set-buffer (process-buffer process)) (goto-char (point-max)) - (setq command (concat command "\r\n")) + (setq command (concat command smtp-end-of-line)) (insert command) (setq smtp-read-point (point)) (if encoder @@ -536,8 +695,8 @@ of the host to connect to. SERVICE is name of the service desired." (smtp-connection-encoder-internal connection))) ;; Escape "." at start of a line. (if (eq (string-to-char data) ?.) - (setq data (concat "." data "\r\n")) - (setq data (concat data "\r\n"))) + (setq data (concat "." data smtp-end-of-line)) + (setq data (concat data smtp-end-of-line))) (if encoder (setq data (funcall encoder data))) (process-send-string process data))) @@ -579,9 +738,7 @@ of the host to connect to. SERVICE is name of the service desired." (mail-strip-quoted-names (buffer-substring this-line this-line-end))))) (erase-buffer) - (insert-string " ") - (insert-string simple-address-list) - (insert-string "\n") + (insert " " simple-address-list "\n") ;; newline --> blank (subst-char-in-region (point-min) (point-max) 10 ? t) ;; comma --> blank @@ -603,6 +760,74 @@ of the host to connect to. SERVICE is name of the service desired." recipient-address-list)) (kill-buffer smtp-address-buffer)))) +;;; @ functions used to show progress message +;;; +(defun smtp-parse-progress-message-format () + "Parse the `smtp-progress-message-format' variable. +Return nil, or a cons of an ordinary format string and a type including +nil, the symbols `b', `k' and `l'." + (when smtp-progress-message-format + (let ((format smtp-progress-message-format) + (index 0) + type) + (while (string-match "%\\([bkl]\\)\\|%\\([^%bkl]\\|\\'\\)" format index) + (if (and (not type) + (match-beginning 1)) + (setq index (match-end 0) + type (intern (match-string 1 format)) + format (replace-match + (cond ((eq type 'b) + (concat "%d/" + (number-to-string (buffer-size)))) + ((eq type 'k) + (if (>= (buffer-size) 512) + (concat "%dk/" + (number-to-string + (/ (+ (buffer-size) 512) 1024)) + "k") + (setq type 'b) + (concat "%d/" + (number-to-string (buffer-size))))) + (t + (concat "%d/" + (number-to-string + (count-lines (point-min) + (point-max)))))) + nil nil format)) + (setq index (1+ (match-end 0)) + format (replace-match "%\\&" nil nil format)))) + (cons format type)))) + +(defun smtp-show-progress-message (def prev) + "Show progress message while sending mails. +DEF is a cons cell which is pre-computed by the +`smtp-parse-progress-message-format' function or nil. +PREV is a number shown last time or nil. +Return a number computed this time." + (when (car def) + (let* ((fmt (car def)) + (type (cdr def)) + (value (cond ((eq type 'b) + (- (point) (point-min))) + ((eq type 'k) + (/ (- (point) (point-min) -512) 1024)) + ((eq type 'l) + (count-lines (point-min) (point))))) + message-log-max) + (unless (and prev + value + (eq type 'k) + (<= value prev)) + (cond ((featurep 'xemacs) + (display-message 'no-log (if value + (format fmt value) + fmt))) + (value + (message fmt value)) + (t + (message "%s" fmt)))) + value))) + (provide 'smtp) ;;; smtp.el ends here