X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/92dfd10c1f4ad23aed4c36d0b6ec825f98fc8305..ac84042c630254697a5244b11bef4375579bbf3f:/lisp/mail/smtpmail.el diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el index 83ffa5d44b..e516133c6a 100644 --- a/lisp/mail/smtpmail.el +++ b/lisp/mail/smtpmail.el @@ -1,6 +1,6 @@ ;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail -;; Copyright (C) 1995, 1996, 2001 Free Software Foundation, Inc. +;; Copyright (C) 1995, 1996, 2001, 2002, 2003 Free Software Foundation, Inc. ;; Author: Tomoji Kagatani ;; Maintainer: Simon Josefsson @@ -35,17 +35,17 @@ ;; Please add these lines in your .emacs(_emacs) or use customize. ;; ;;(setq send-mail-function 'smtpmail-send-it) ; if you use `mail' -;;(setq message-send-mail-function 'smtpmail-send-it) ; if you are using Gnus. +;;(setq message-send-mail-function 'smtpmail-send-it) ; if you use message/Gnus ;;(setq smtpmail-default-smtp-server "YOUR SMTP HOST") ;;(setq smtpmail-local-domain "YOUR DOMAIN NAME") ;;(setq smtpmail-sendto-domain "YOUR DOMAIN NAME") ;;(setq smtpmail-debug-info t) ; only to debug problems -;;(setq smtpmail-auth-credentials +;;(setq smtpmail-auth-credentials ; or use ~/.authinfo ;; '(("YOUR SMTP HOST" 25 "username" "password"))) ;;(setq smtpmail-starttls-credentials ;; '(("YOUR SMTP HOST" 25 "~/.my_smtp_tls.key" "~/.my_smtp_tls.cert"))) -;; To queue mail, set smtpmail-queue-mail to t and use +;; To queue mail, set smtpmail-queue-mail to t and use ;; smtpmail-send-queued-mail to send. ;; Modified by Stephen Cranefield , @@ -66,11 +66,15 @@ ;;; Code: (require 'sendmail) -(require 'time-stamp) (autoload 'starttls-open-stream "starttls") (autoload 'starttls-negotiate "starttls") (autoload 'mail-strip-quoted-names "mail-utils") +(autoload 'message-make-date "message") +(autoload 'message-make-message-id "message") (autoload 'rfc2104-hash "rfc2104") +(autoload 'netrc-parse "netrc") +(autoload 'netrc-machine "netrc") +(autoload 'netrc-get "netrc") ;;; (defgroup smtpmail nil @@ -79,11 +83,12 @@ (defcustom smtpmail-default-smtp-server nil - "*Specify default SMTP server." + "*Specify default SMTP server. +This only has effect if you specify it before loading the smtpmail library." :type '(choice (const nil) string) :group 'smtpmail) -(defcustom smtpmail-smtp-server +(defcustom smtpmail-smtp-server (or (getenv "SMTPSERVER") smtpmail-default-smtp-server) "*The name of the host running SMTP server." :type '(choice (const nil) string) @@ -136,7 +141,7 @@ The commands enables verbose information from the SMTP server." :type 'boolean :group 'smtpmail) -(defcustom smtpmail-queue-mail nil +(defcustom smtpmail-queue-mail nil "*Specify if mail is queued (if t) or sent immediately (if nil). If queued, it is stored in the directory `smtpmail-queue-dir' and sent with `smtpmail-send-queued-mail'." @@ -148,19 +153,21 @@ and sent with `smtpmail-send-queued-mail'." :type 'directory :group 'smtpmail) -(defcustom smtpmail-auth-credentials '(("" 25 "" nil)) - "Specify username and password for servers. -It is a list of four-element lists that contain, in order, +(defcustom smtpmail-auth-credentials "~/.authinfo" + "Specify username and password for servers, directly or via .netrc file. +This variable can either be a filename pointing to a file in netrc(5) +format, or list of four-element lists that contain, in order, `servername' (a string), `port' (an integer), `user' (a string) and -`password' (a string, or nil to query the user when needed). -If you need to enter a `realm' too, add it to the user string, so that -it looks like `user@realm'." - :type '(repeat (list (string :tag "Server") +`password' (a string, or nil to query the user when needed). If you +need to enter a `realm' too, add it to the user string, so that it +looks like `user@realm'." + :type '(choice file + (repeat (list (string :tag "Server") (integer :tag "Port") (string :tag "Username") (choice (const :tag "Query when needed" nil) - (string :tag "Password")))) - :version "21.1" + (string :tag "Password"))))) + :version "21.4" :group 'smtpmail) (defcustom smtpmail-starttls-credentials '(("" 25 "" "")) @@ -189,6 +196,8 @@ This is relative to `smtpmail-queue-dir'.") (defvar smtpmail-address-buffer) (defvar smtpmail-recipient-address-list) +(defvar smtpmail-queue-counter 0) + ;; Buffer-local variable. (defvar smtpmail-read-point) @@ -202,6 +211,9 @@ This is relative to `smtpmail-queue-dir'.") ;;; ;;; +(defvar smtpmail-mail-address nil + "Value to use for envelope-from address for mail from ambient buffer.") + ;;;###autoload (defun smtpmail-send-it () (let ((errbuf (if mail-interactive @@ -211,6 +223,11 @@ This is relative to `smtpmail-queue-dir'.") (case-fold-search nil) delimline (mailbuf (current-buffer)) + ;; 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)) (smtpmail-code-conv-from (if enable-multibyte-characters (let ((sendmail-coding-system smtpmail-code-conv-from)) @@ -251,7 +268,7 @@ This is relative to `smtpmail-queue-dir'.") ;; they put one in themselves. (goto-char (point-min)) (if (not (re-search-forward "^From:" delimline t)) - (let* ((login user-mail-address) + (let* ((login smtpmail-mail-address) (fullname (user-full-name))) (cond ((eq mail-from-style 'angles) (insert "From: " fullname) @@ -285,7 +302,7 @@ This is relative to `smtpmail-queue-dir'.") ;; ... then undo escaping of matching parentheses, ;; including matching nested parentheses. (goto-char fullname-start) - (while (re-search-forward + (while (re-search-forward "\\(\\=\\|[^\\]\\(\\\\\\\\\\)*\\)\\\\(\\(\\([^\\]\\|\\\\\\\\\\)*\\)\\\\)" fullname-end 1) (replace-match "\\1(\\3)" t) @@ -293,6 +310,14 @@ This is relative to `smtpmail-queue-dir'.") (insert ")\n")) ((null mail-from-style) (insert "From: " login "\n"))))) + ;; Insert a `Message-Id:' field if there isn't one yet. + (goto-char (point-min)) + (unless (re-search-forward "^Message-Id:" delimline t) + (insert "Message-Id: " (message-make-message-id) "\n")) + ;; Insert a `Date:' field if there isn't one yet. + (goto-char (point-min)) + (unless (re-search-forward "^Date:" delimline t) + (insert "Date: " (message-make-date) "\n")) ;; Insert an extra newline if we need it to work around ;; Sun's bug that swallows newlines. (goto-char (1+ delimline)) @@ -303,8 +328,7 @@ This is relative to `smtpmail-queue-dir'.") (if (re-search-forward "^FCC:" delimline t) (mail-do-fcc delimline)) (if mail-interactive - (save-excursion - (set-buffer errbuf) + (with-current-buffer errbuf (erase-buffer)))) ;; ;; @@ -313,26 +337,30 @@ This is relative to `smtpmail-queue-dir'.") (setq smtpmail-recipient-address-list (smtpmail-deduce-address-list tembuf (point-min) delimline)) (kill-buffer smtpmail-address-buffer) - + (smtpmail-do-bcc delimline) ; Send or queue (if (not smtpmail-queue-mail) (if (not (null smtpmail-recipient-address-list)) - (if (not (smtpmail-via-smtp + (if (not (smtpmail-via-smtp smtpmail-recipient-address-list tembuf)) (error "Sending failed; SMTP protocol error")) (error "Sending failed; no recipients")) - (let* ((file-data (concat - smtpmail-queue-dir - (concat (time-stamp-yyyy-mm-dd) - "_" (time-stamp-hh:mm:ss)))) - (file-data (convert-standard-filename file-data)) - (file-elisp (concat file-data ".el")) + (let* ((file-data + (expand-file-name + (format "%s_%i" + (format-time-string "%Y-%m-%d_%H:%M:%S") + (setq smtpmail-queue-counter + (1+ smtpmail-queue-counter))) + smtpmail-queue-dir)) + (file-data (convert-standard-filename file-data)) + (file-elisp (concat file-data ".el")) (buffer-data (create-file-buffer file-data)) (buffer-elisp (create-file-buffer file-elisp)) (buffer-scratch "*queue-mail*")) - (save-excursion - (set-buffer buffer-data) + (unless (file-exists-p smtpmail-queue-dir) + (make-directory smtpmail-queue-dir t)) + (with-current-buffer buffer-data (erase-buffer) (insert-buffer tembuf) (write-file file-data) @@ -341,12 +369,12 @@ This is relative to `smtpmail-queue-dir'.") (insert (concat "(setq smtpmail-recipient-address-list '" (prin1-to-string smtpmail-recipient-address-list) - ")\n")) + ")\n")) (write-file file-elisp) (set-buffer (generate-new-buffer buffer-scratch)) (insert (concat file-data "\n")) - (append-to-file (point-min) - (point-max) + (append-to-file (point-min) + (point-max) smtpmail-queue-index) ) (kill-buffer buffer-scratch) @@ -356,35 +384,37 @@ 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) - ;;; Get index, get first mail, send it, get second mail, etc... - (let ((buffer-index (find-file-noselect smtpmail-queue-index)) - (file-msg "") - (tembuf nil)) - (save-excursion - (set-buffer buffer-index) + (with-temp-buffer + ;;; Get index, get first mail, send it, update index, get second + ;;; mail, send it, etc... + (let ((file-msg "")) + (insert-file-contents smtpmail-queue-index) (beginning-of-buffer) (while (not (eobp)) - (setq file-msg (buffer-substring (point) (save-excursion - (end-of-line) - (point)))) + (setq file-msg (buffer-substring (point) (line-end-position))) (load file-msg) - (setq tembuf (find-file-noselect file-msg)) - (if (not (null smtpmail-recipient-address-list)) - (if (not (smtpmail-via-smtp smtpmail-recipient-address-list - tembuf)) - (error "Sending failed; SMTP protocol error")) - (error "Sending failed; no recipients")) + ;; Insert the message literally: it is already encoded as per + ;; the MIME headers, and code conversions might guess the + ;; encoding wrongly. + (with-temp-buffer + (let ((coding-system-for-read 'no-conversion)) + (insert-file-contents file-msg)) + (let ((smtpmail-mail-address + (or (and mail-specify-envelope-from (mail-envelope-from)) + user-mail-address))) + (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")) - (kill-buffer tembuf) - (kill-line 1)) - (set-buffer buffer-index) - (save-buffer smtpmail-queue-index) - (kill-buffer buffer-index) - ))) + (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) @@ -436,7 +466,9 @@ This is relative to `smtpmail-queue-dir'.") (let ((cred (smtpmail-find-credentials smtpmail-starttls-credentials host port))) (if (null (and cred (condition-case () - (call-process "starttls") + (progn + (require 'starttls) + (call-process starttls-program)) (error nil)))) ;; The normal case. (open-network-stream "SMTP" process-buffer host port) @@ -454,7 +486,17 @@ This is relative to `smtpmail-queue-dir'.") (defun smtpmail-try-auth-methods (process supported-extensions host port) (let* ((mechs (cdr-safe (assoc 'auth supported-extensions))) (mech (car (smtpmail-intersection smtpmail-auth-supported mechs))) - (cred (smtpmail-find-credentials smtpmail-auth-credentials host port)) + (cred (if (stringp smtpmail-auth-credentials) + (let* ((netrc (netrc-parse smtpmail-auth-credentials)) + (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") + (netrc-get hostentry "password")))) + (smtpmail-find-credentials + smtpmail-auth-credentials host port))) (passwd (when cred (or (smtpmail-cred-passwd cred) (read-passwd @@ -462,7 +504,7 @@ 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)) @@ -499,9 +541,10 @@ This is relative to `smtpmail-queue-dir'.") (>= (car ret) 400)) (throw 'done nil))) (t - (error "Mechanism %s not implemented" mech))) + (error "Mechanism %s not implemented" mech))) ;; Remember the password. - (unless (smtpmail-cred-passwd cred) + (when (and (not (stringp smtpmail-auth-credentials)) + (null (smtpmail-cred-passwd cred))) (setcar (cdr (cdr (cdr cred))) passwd))))) (defun smtpmail-via-smtp (recipient smtpmail-text-buffer) @@ -509,6 +552,12 @@ This is relative to `smtpmail-queue-dir'.") (host (or smtpmail-smtp-server (error "`smtpmail-smtp-server' not defined"))) (port smtpmail-smtp-service) + ;; 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)) response-code greeting process-buffer @@ -520,8 +569,7 @@ This is relative to `smtpmail-queue-dir'.") (get-buffer-create (format "*trace of SMTP session to %s*" host))) ;; clear the trace buffer of old output - (save-excursion - (set-buffer process-buffer) + (with-current-buffer process-buffer (erase-buffer)) ;; open the connection to the server @@ -531,13 +579,12 @@ This is relative to `smtpmail-queue-dir'.") ;; set the send-filter (set-process-filter process 'smtpmail-process-filter) - (save-excursion - (set-buffer process-buffer) + (with-current-buffer process-buffer (set-buffer-process-coding-system 'raw-text-unix 'raw-text-unix) (make-local-variable 'smtpmail-read-point) (setq smtpmail-read-point (point-min)) - + (if (or (null (car (setq greeting (smtpmail-read-response process)))) (not (integerp (car greeting))) (>= (car greeting) 400)) @@ -584,7 +631,7 @@ This is relative to `smtpmail-queue-dir'.") (if (and do-starttls (smtpmail-find-credentials smtpmail-starttls-credentials host port) (member 'starttls supported-extensions) - (process-id process)) + (numberp (process-id process))) (progn (smtpmail-send-command process (format "STARTTLS")) (if (or (null (car (setq response-code (smtpmail-read-response process)))) @@ -594,7 +641,7 @@ This is relative to `smtpmail-queue-dir'.") (starttls-negotiate process) (setq do-starttls nil)) (setq do-ehlo nil)))) - + (smtpmail-try-auth-methods process supported-extensions host port) (if (or (member 'onex supported-extensions) @@ -624,23 +671,17 @@ This is relative to `smtpmail-queue-dir'.") (>= (car response-code) 400)) (throw 'done nil)))) - ;; MAIL FROM: + ;; MAIL FROM: (let ((size-part (if (or (member 'size supported-extensions) (assoc 'size supported-extensions)) (format " SIZE=%d" - (save-excursion - (set-buffer smtpmail-text-buffer) + (with-current-buffer smtpmail-text-buffer ;; 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) @@ -660,9 +701,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" - (or mail-envelope-from - user-mail-address) + (smtpmail-send-command process (format "MAIL FROM:<%s>%s%s" + envelope-from size-part body-part)) @@ -671,11 +711,11 @@ This is relative to `smtpmail-queue-dir'.") (>= (car response-code) 400)) (throw 'done nil) )) - - ;; RCPT TO: + + ;; RCPT TO: (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)) @@ -685,7 +725,7 @@ This is relative to `smtpmail-queue-dir'.") (throw 'done nil) ) )) - + ;; DATA (smtpmail-send-command process "DATA") @@ -713,8 +753,7 @@ This is relative to `smtpmail-queue-dir'.") ; (throw 'done nil)) t )) (if process - (save-excursion - (set-buffer (process-buffer process)) + (with-current-buffer (process-buffer process) (smtpmail-send-command process "QUIT") (smtpmail-read-response process) @@ -723,12 +762,13 @@ This is relative to `smtpmail-queue-dir'.") ; (>= (car response-code) 400)) ; (throw 'done nil) ; ) - (delete-process process)))))) + (delete-process process) + (unless smtpmail-debug-info + (kill-buffer process-buffer))))))) (defun smtpmail-process-filter (process output) - (save-excursion - (set-buffer (process-buffer process)) + (with-current-buffer (process-buffer process) (goto-char (point-max)) (insert output))) @@ -749,7 +789,7 @@ This is relative to `smtpmail-queue-dir'.") (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)) @@ -764,10 +804,10 @@ This is relative to `smtpmail-queue-dir'.") nil (setq response-continue nil) (setq return-value - (cons (string-to-int - (buffer-substring begin end)) + (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))) @@ -776,7 +816,7 @@ This is relative to `smtpmail-queue-dir'.") (progn (setq smtpmail-read-point match-end) (setq response-continue nil) - (setq return-value + (setq return-value (cons nil (nreverse response-strings))) ) ))) @@ -800,7 +840,7 @@ This is relative to `smtpmail-queue-dir'.") smtpmail-code-conv-from) (setq data (string-as-multibyte (encode-coding-string data smtpmail-code-conv-from)))) - + (if smtpmail-debug-info (insert data "\r\n")) @@ -813,39 +853,21 @@ 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) - - (save-excursion - (set-buffer buffer) + (let ((data-continue t) sending-data) + (with-current-buffer buffer (goto-char (point-min))) - (while data-continue - (save-excursion - (set-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) - ) - ) - ) - + (with-current-buffer buffer + (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:
." (unwind-protect - (save-excursion - (set-buffer smtpmail-address-buffer) (erase-buffer) + (with-current-buffer smtpmail-address-buffer + (erase-buffer) (let ((case-fold-search t) (simple-address-list "") @@ -856,9 +878,11 @@ This is relative to `smtpmail-queue-dir'.") (goto-char (point-min)) ;; RESENT-* fields should stop processing of regular fields. (save-excursion - (if (re-search-forward "^Resent-\\(to\\|cc\\|bcc\\):" header-end t) - (setq addr-regexp "^Resent-\\(to\\|cc\\|bcc\\):") - (setq addr-regexp "^\\(To:\\|Cc:\\|Bcc:\\)"))) + (setq addr-regexp + (if (re-search-forward "^Resent-\\(to\\|cc\\|bcc\\):" + header-end t) + "^Resent-\\(to\\|cc\\|bcc\\):" + "^\\(To:\\|Cc:\\|Bcc:\\)"))) (while (re-search-forward addr-regexp header-end t) (replace-match "") @@ -915,4 +939,5 @@ many continuation lines." (provide 'smtpmail) +;;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466 ;;; smtpmail.el ends here