User: simon Date: 06/03/08 11:12:56 Modified: packages/xemacs-packages/mail-lib smtpmail.el Log: Sync with GNU Emacs, adds support for GnuTLS and some other fixes. Revision Changes Path 1.24 +135 -110 XEmacs/packages/xemacs-packages/mail-lib/smtpmail.el Index: smtpmail.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/mail-lib/smtpmail.el,v retrieving revision 1.23 retrieving revision 1.24 diff -u -p -r1.23 -r1.24 --- smtpmail.el 2005/10/26 07:53:20 1.23 +++ smtpmail.el 2006/03/08 10:12:55 1.24 ＠＠ -1,7 +1,7 ＠＠ ;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail -;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005 -;; Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005, +;; 2006 Free Software Foundation, Inc. ;; Author: Tomoji Kagatani <kagatani(a)rbc.ncl.omron.co.jp&gt; ;; Maintainer: Simon Josefsson <simon(a)josefsson.org&gt; ＠＠ -26,11 +26,9 ＠＠ ;; You should have received a copy of the GNU General Public License ;; along with XEmacs; 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. -;;; Synched up with: Emacs 21.3 from CVS 2002-09-17 - ;;; Commentary: ;; Send Mail to smtp host from smtpmail temp buffer. ＠＠ -170,9 +168,9 ＠＠ need to enter a `realm' too, add it to t looks like `user(a)realm&#39;.&quot; :type '(choice file (repeat (list (string :tag "Server") - (integer :tag "Port") - (string :tag "Username") - (choice (const :tag "Query when needed" nil) + (integer :tag "Port") + (string :tag "Username") + (choice (const :tag "Query when needed" nil) (string :tag "Password"))))) :group 'smtpmail) ＠＠ -208,7 +206,7 ＠＠ This is relative to `smtpmail-queue-dir' (defvar smtpmail-queue-index (concat smtpmail-queue-dir smtpmail-queue-index-file)) -(defconst smtpmail-auth-supported '(cram-md5 login) +(defconst smtpmail-auth-supported '(cram-md5 plain login) "List of supported SMTP AUTH mechanisms.") ;;; ＠＠ -216,7 +214,7 ＠＠ This is relative to `smtpmail-queue-dir' ;;; (defvar smtpmail-mail-address nil - "Value of `user-mail-address' in ambient buffer.") + "Value to use for envelope-from address for mail from ambient buffer.") ;;;###autoload (defun smtpmail-send-it () ＠＠ -227,7 +225,11 ＠＠ This is relative to `smtpmail-queue-dir' (case-fold-search nil) delimline (mailbuf (current-buffer)) - (smtpmail-mail-address (user-mail-address)) ;; XEmacs + ;; Examine this variable now, so that + ;; local binding in the mail buffer will take effect. + (smtpmail-mail-address + (or (and mail-specify-envelope-from (mail-envelope-from)) + (user-mail-address))) ;; XEmacs ;; XEmacs: Don't frob `smtpmail-code-conv-from' here ) (unwind-protect ＠＠ -359,9 +361,11 ＠＠ This is relative to `smtpmail-queue-dir' (buffer-data (create-file-buffer file-data)) (buffer-elisp (create-file-buffer file-elisp)) (buffer-scratch "*queue-mail*")) + (unless (file-exists-p smtpmail-queue-dir) + (make-directory smtpmail-queue-dir t)) (with-current-buffer buffer-data (erase-buffer) - (insert-buffer tembuf) + (insert-buffer-substring tembuf) (write-file file-data) (set-buffer buffer-elisp) (erase-buffer) ＠＠ -383,6 +387,7 ＠＠ This is relative to `smtpmail-queue-dir' (if (bufferp errbuf) (kill-buffer errbuf))))) +;;;###autoload (defun smtpmail-send-queued-mail () "Send mail that was queued as a result of setting `smtpmail-queue-mail'." (interactive) ＠＠ -393,7 +398,7 ＠＠ This is relative to `smtpmail-queue-dir' (insert-file-contents smtpmail-queue-index) (goto-char (point-min)) (while (not (eobp)) - (setq file-msg (buffer-substring (point) (point-at-eol))) ;; XEmacs + (setq file-msg (buffer-substring (point) (line-end-position))) (load file-msg) ;; Insert the message literally: it is already encoded as per ;; the MIME headers, and code conversions might guess the ＠＠ -401,14 +406,17 ＠＠ This is relative to `smtpmail-queue-dir' (with-temp-buffer (let ((coding-system-for-read 'binary)) ;; XEmacs (insert-file-contents file-msg)) - (if (not (null smtpmail-recipient-address-list)) - (if (not (smtpmail-via-smtp smtpmail-recipient-address-list - (current-buffer))) - (error "Sending failed; SMTP protocol error")) - (error "Sending failed; no recipients"))) + (let ((smtpmail-mail-address + (or (and mail-specify-envelope-from (mail-envelope-from)) + (user-mail-address)))) ;; XEmacs + (if (not (null smtpmail-recipient-address-list)) + (if (not (smtpmail-via-smtp smtpmail-recipient-address-list + (current-buffer))) + (error "Sending failed; SMTP protocol error")) + (error "Sending failed; no recipients")))) (delete-file file-msg) (delete-file (concat file-msg ".el")) - (delete-region (point) (save-excursion (forward-line 1) (point)))) + (delete-region (point-at-bol) (point-at-bol 2))) (write-region (point-min) (point-max) smtpmail-queue-index)))) ;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer) ＠＠ -457,25 +465,41 ＠＠ This is relative to `smtpmail-queue-dir' (push el2 result))) (nreverse result))) +(defvar starttls-extra-args) +(defvar starttls-extra-arguments) + (defun smtpmail-open-stream (process-buffer host port) (let ((cred (smtpmail-find-credentials smtpmail-starttls-credentials host port))) (if (null (and cred (condition-case () - (progn + (with-no-warnings (require 'starttls) - (call-process starttls-program)) + (call-process (if starttls-use-gnutls + starttls-gnutls-program + starttls-program))) (error nil)))) ;; The normal case. (open-network-stream "SMTP" process-buffer host port) (let* ((cred-key (smtpmail-cred-key cred)) (cred-cert (smtpmail-cred-cert cred)) (starttls-extra-args - (when (and (stringp cred-key) (stringp cred-cert) - (file-regular-p - (setq cred-key (expand-file-name cred-key))) - (file-regular-p - (setq cred-cert (expand-file-name cred-cert)))) - (list "--key-file" cred-key "--cert-file" cred-cert)))) + (append + starttls-extra-args + (when (and (stringp cred-key) (stringp cred-cert) + (file-regular-p + (setq cred-key (expand-file-name cred-key))) + (file-regular-p + (setq cred-cert (expand-file-name cred-cert)))) + (list "--key-file" cred-key "--cert-file" cred-cert)))) + (starttls-extra-arguments + (append + starttls-extra-arguments + (when (and (stringp cred-key) (stringp cred-cert) + (file-regular-p + (setq cred-key (expand-file-name cred-key))) + (file-regular-p + (setq cred-cert (expand-file-name cred-cert)))) + (list "--x509keyfile" cred-key "--x509certfile" cred-cert))))) (starttls-open-stream "SMTP" process-buffer host port))))) (defun smtpmail-try-auth-methods (process supported-extensions host port) ＠＠ -483,9 +507,9 ＠＠ This is relative to `smtpmail-queue-dir' (mech (car (smtpmail-intersection smtpmail-auth-supported mechs))) (cred (if (stringp smtpmail-auth-credentials) (let* ((netrc (netrc-parse smtpmail-auth-credentials)) - (hostentry (netrc-machine - netrc host (format "%s" (or port "smtp")) - "smtp"))) + (port-name (format "%s" (or port "smtp"))) + (hostentry (netrc-machine netrc host port-name + port-name))) (when hostentry (list host port (netrc-get hostentry "login") ＠＠ -499,10 +523,10 ＠＠ This is relative to `smtpmail-queue-dir' (smtpmail-cred-server cred) (smtpmail-cred-port cred)))))) ret) - (when cred + (when (and cred mech) (cond ((eq mech 'cram-md5) - (smtpmail-send-command process (format "AUTH %s" mech)) + (smtpmail-send-command process (upcase (format "AUTH %s" mech))) (if (or (null (car (setq ret (smtpmail-read-response process)))) (not (integerp (car ret))) (>= (car ret) 400)) ＠＠ -535,6 +559,24 ＠＠ This is relative to `smtpmail-queue-dir' (not (integerp (car ret))) (>= (car ret) 400)) (throw 'done nil))) + ((eq mech 'plain) + ;; We used to send an empty initial request, and wait for an + ;; empty response, and then send the password, but this + ;; violate a SHOULD in RFC 2222 paragraph 5.1. Note that this + ;; is not sent if the server did not advertise AUTH PLAIN in + ;; the EHLO response. See RFC 2554 for more info. + (smtpmail-send-command process + (concat "AUTH PLAIN " + (base64-encode-string + (concat "\0" + (smtpmail-cred-user cred) + "\0" + passwd)))) + (if (or (null (car (setq ret (smtpmail-read-response process)))) + (not (integerp (car ret))) + (not (equal (car ret) 235))) + (throw 'done nil))) + (t (error "Mechanism %s not implemented" mech))) ;; Remember the password. ＠＠ -547,10 +589,12 ＠＠ This is relative to `smtpmail-queue-dir' (host (or smtpmail-smtp-server (error "`smtpmail-smtp-server' not defined"))) (port smtpmail-smtp-service) - (envelope-from (or (mail-envelope-from) - smtpmail-mail-address - ;; XEmacs: - (user-mail-address))) + ;; smtpmail-mail-address should be set to the appropriate + ;; buffer-local value by the caller, but in case not: + (envelope-from (or smtpmail-mail-address + (and mail-specify-envelope-from + (mail-envelope-from)) + (user-mail-address))) ;; XEmacs response-code greeting process-buffer ＠＠ -563,6 +607,7 ＠＠ This is relative to `smtpmail-queue-dir' ;; clear the trace buffer of old output (with-current-buffer process-buffer + (setq buffer-undo-list t) (erase-buffer)) ;; open the connection to the server ＠＠ -666,7 +711,7 ＠＠ This is relative to `smtpmail-queue-dir' (>= (car response-code) 400)) (throw 'done nil)))) - ;; MAIL FROM: <sender> + ;; MAIL FROM:<sender> (let ((size-part (if (or (member 'size supported-extensions) (assoc 'size supported-extensions)) ＠＠ -675,13 +720,8 ＠＠ This is relative to `smtpmail-queue-dir' ;; size estimate: (+ (- (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))) + ;; because of CR-LF representation: + (count-lines (point-min) (point-max))))) "")) (body-part (if (member '8bitmime supported-extensions) ＠＠ -701,8 +741,8 ＠＠ This is relative to `smtpmail-queue-dir' "") ""))) ; (smtpmail-send-command process (format "MAIL FROM:%s＠%s" (user-login-name) (smtpmail-fqdn))) - (smtpmail-send-command process (format "MAIL FROM: <%s>%s%s" - envelope-from + (smtpmail-send-command process (format "MAIL FROM:<%s>%s%s" + envelope-from size-part body-part)) ＠＠ -712,10 +752,10 ＠＠ This is relative to `smtpmail-queue-dir' (throw 'done nil) )) - ;; RCPT TO: <recipient> + ;; RCPT TO:<recipient> (let ((n 0)) (while (not (null (nth n recipient))) - (smtpmail-send-command process (format "RCPT TO: <%s>" (smtpmail-maybe-append-domain (nth n recipient)))) + (smtpmail-send-command process (format "RCPT TO:<%s>" (smtpmail-maybe-append-domain (nth n recipient)))) (setq n (1+ n)) (setq response-code (smtpmail-read-response process)) ＠＠ -778,49 +818,49 ＠＠ This is relative to `smtpmail-queue-dir' (response-continue t) (return-value '(nil ())) match-end) + (catch 'done + (while response-continue + (goto-char smtpmail-read-point) + (while (not (search-forward "\r\n" nil t)) + (unless (memq (process-status process) '(open run)) + (throw 'done nil)) + (accept-process-output process) + (goto-char smtpmail-read-point)) - (while response-continue - (goto-char smtpmail-read-point) - (while (not (search-forward "\r\n" nil t)) - (accept-process-output process) - (goto-char smtpmail-read-point)) - - (setq match-end (point)) - (setq response-strings - (cons (buffer-substring smtpmail-read-point (- match-end 2)) - response-strings)) - - (goto-char smtpmail-read-point) - (if (looking-at "[0-9]+ ") - (let ((begin (match-beginning 0)) - (end (match-end 0))) - (if smtpmail-debug-info - (message "%s" (car response-strings))) - - (setq smtpmail-read-point match-end) - - ;; ignore lines that start with "0" - (if (looking-at "0[0-9]+ ") - nil + (setq match-end (point)) + (setq response-strings + (cons (buffer-substring smtpmail-read-point (- match-end 2)) + response-strings)) + + (goto-char smtpmail-read-point) + (if (looking-at "[0-9]+ ") + (let ((begin (match-beginning 0)) + (end (match-end 0))) + (if smtpmail-debug-info + (message "%s" (car response-strings))) + + (setq smtpmail-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-number + (buffer-substring begin end)) + (nreverse response-strings))))) + + (if (looking-at "[0-9]+-") + (progn (if smtpmail-debug-info + (message "%s" (car response-strings))) + (setq smtpmail-read-point match-end) + (setq response-continue t)) + (progn + (setq smtpmail-read-point match-end) (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 smtpmail-debug-info - (message "%s" (car response-strings))) - (setq smtpmail-read-point match-end) - (setq response-continue t)) - (progn - (setq smtpmail-read-point match-end) - (setq response-continue nil) - (setq return-value - (cons nil (nreverse response-strings))) - ) - ))) - (setq smtpmail-read-point match-end) + (cons nil (nreverse response-strings))))))) + (setq smtpmail-read-point match-end)) return-value)) ＠＠ -853,31 +893,15 ＠＠ This is relative to `smtpmail-queue-dir' ) (defun smtpmail-send-data (process buffer) - (let - ((data-continue t) - (sending-data nil) - this-line - this-line-end) - + (let ((data-continue t) sending-data) (with-current-buffer buffer (goto-char (point-min))) - (while data-continue (with-current-buffer buffer - (beginning-of-line) - (setq this-line (point)) - (end-of-line) - (setq this-line-end (point)) - (setq sending-data nil) - (setq sending-data (buffer-substring this-line this-line-end)) - (if (/= (forward-line 1) 0) - (setq data-continue nil))) - - (smtpmail-send-data-1 process sending-data) - ) - ) - ) - + (setq sending-data (buffer-substring (point-at-bol) (point-at-eol))) + (end-of-line 2) + (setq data-continue (not (eobp)))) + (smtpmail-send-data-1 process sending-data)))) (defun smtpmail-deduce-address-list (smtpmail-text-buffer header-start header-end) "Get address list suitable for smtp RCPT TO: <address>." ＠＠ -955,4 +979,5 ＠＠ many continuation lines." (provide 'smtpmail) +;;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466 ;;; smtpmail.el ends here