X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/b03f96dc5a6651d1dc84b81b2a15cad6908b9809..73b0cd50031a714347109169ceb8bacae338612a:/lisp/mail/smtpmail.el diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el index 07df9d0afd..f726304704 100644 --- a/lisp/mail/smtpmail.el +++ b/lisp/mail/smtpmail.el @@ -1,7 +1,6 @@ ;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail -;; Copyright (C) 1995, 1996, 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008 Free Software Foundation, Inc. +;; Copyright (C) 1995-1996, 2001-2011 Free Software Foundation, Inc. ;; Author: Tomoji Kagatani ;; Maintainer: Simon Josefsson @@ -14,10 +13,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -25,9 +24,7 @@ ;; GNU 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 -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -48,8 +45,8 @@ ;; Where the 25 equals the value of `smtpmail-smtp-service', it can be an ;; integer or a string, just as long as they match (eq). -;; To queue mail, set smtpmail-queue-mail to t and use -;; smtpmail-send-queued-mail to send. +;; To queue mail, set `smtpmail-queue-mail' to t and use +;; `smtpmail-send-queued-mail' to send. ;; Modified by Stephen Cranefield , ;; 22/6/99, to support SMTP Authentication by the AUTH=LOGIN mechanism. @@ -69,6 +66,7 @@ ;;; Code: (require 'sendmail) +(autoload 'starttls-any-program-available "starttls") (autoload 'starttls-open-stream "starttls") (autoload 'starttls-negotiate "starttls") (autoload 'mail-strip-quoted-names "mail-utils") @@ -79,6 +77,7 @@ (autoload 'netrc-machine "netrc") (autoload 'netrc-get "netrc") (autoload 'password-read "password-cache") +(autoload 'auth-source-user-or-password "auth-source") ;;; (defgroup smtpmail nil @@ -122,8 +121,7 @@ Don't bother to set this unless you have get an error like: when sending mail, and the *trace of SMTP session to * buffer includes an exchange like: RCPT TO: - 501 : recipient address must contain a domain -" + 501 : recipient address must contain a domain." :type '(choice (const nil) string) :group 'smtpmail) @@ -169,9 +167,9 @@ 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) + (integer :tag "Port") + (string :tag "Username") + (choice (const :tag "Query when needed" nil) (string :tag "Password"))))) :version "22.1" :group 'smtpmail) @@ -218,7 +216,8 @@ This is relative to `smtpmail-queue-dir'." (defvar smtpmail-read-point) (defconst smtpmail-auth-supported '(cram-md5 plain login) - "List of supported SMTP AUTH mechanisms.") + "List of supported SMTP AUTH mechanisms. +The list is in preference order.") (defvar smtpmail-mail-address nil "Value to use for envelope-from address for mail from ambient buffer.") @@ -242,11 +241,10 @@ This is relative to `smtpmail-queue-dir'." (let ((sendmail-coding-system smtpmail-code-conv-from)) (select-message-coding-system))))) (unwind-protect - (save-excursion - (set-buffer tembuf) + (with-current-buffer tembuf (erase-buffer) - ;; Use the same buffer-file-coding-system as in the mail - ;; buffer, otherwise any write-region invocations (e.g., in + ;; Use the same `buffer-file-coding-system' as in the mail + ;; buffer, otherwise any `write-region' invocations (e.g., in ;; mail-do-fcc below) will annoy with asking for a suitable ;; encoding. (set-buffer-file-coding-system smtpmail-code-conv-from nil t) @@ -258,7 +256,7 @@ This is relative to `smtpmail-queue-dir'." ;; Change header-delimiter to be what sendmail expects. (mail-sendmail-undelimit-header) (setq delimline (point-marker)) -;; (sendmail-synch-aliases) + ;; (sendmail-synch-aliases) (if mail-aliases (expand-mail-aliases (point-min) delimline)) (goto-char (point-min)) @@ -269,7 +267,7 @@ This is relative to `smtpmail-queue-dir'." (let ((case-fold-search t)) ;; We used to process Resent-... headers here, ;; but it was not done properly, and the job - ;; is done correctly in smtpmail-deduce-address-list. + ;; is done correctly in `smtpmail-deduce-address-list'. ;; Don't send out a blank subject line (goto-char (point-min)) (if (re-search-forward "^Subject:\\([ \t]*\n\\)+\\b" delimline t) @@ -356,7 +354,7 @@ This is relative to `smtpmail-queue-dir'." ;; Find and handle any FCC fields. (goto-char (point-min)) (if (re-search-forward "^FCC:" delimline t) - ;; Force mail-do-fcc to use the encoding of the mail + ;; Force `mail-do-fcc' to use the encoding of the mail ;; buffer to encode outgoing messages on FCC files. (let ((coding-system-for-write smtpmail-code-conv-from)) (mail-do-fcc delimline))) @@ -364,15 +362,13 @@ This is relative to `smtpmail-queue-dir'." (with-current-buffer errbuf (erase-buffer)))) ;; - ;; - ;; (setq smtpmail-address-buffer (generate-new-buffer "*smtp-mail*")) (setq smtpmail-recipient-address-list - (smtpmail-deduce-address-list tembuf (point-min) delimline)) + (smtpmail-deduce-address-list tembuf (point-min) delimline)) (kill-buffer smtpmail-address-buffer) (smtpmail-do-bcc delimline) - ; Send or queue + ;; Send or queue (if (not smtpmail-queue-mail) (if (not (null smtpmail-recipient-address-list)) (if (not (smtpmail-via-smtp @@ -395,7 +391,14 @@ This is relative to `smtpmail-queue-dir'." (make-directory smtpmail-queue-dir t)) (with-current-buffer buffer-data (erase-buffer) - (set-buffer-file-coding-system smtpmail-code-conv-from nil t) + (set-buffer-file-coding-system + ;; We will be reading the file with no-conversion in + ;; smtpmail-send-queued-mail below, so write it out + ;; with Unix EOLs. + (coding-system-change-eol-conversion + (or smtpmail-code-conv-from 'undecided) + 'unix) + nil t) (insert-buffer-substring tembuf) (write-file file-data) (set-buffer buffer-elisp) @@ -423,8 +426,8 @@ This is relative to `smtpmail-queue-dir'." "Send mail that was queued as a result of setting `smtpmail-queue-mail'." (interactive) (with-temp-buffer - ;;; Get index, get first mail, send it, update index, get second - ;;; mail, send it, etc... + ;; Get index, get first mail, send it, update index, get second + ;; mail, send it, etc... (let ((file-msg "") (qfile (expand-file-name smtpmail-queue-index-file smtpmail-queue-dir))) @@ -452,7 +455,7 @@ This is relative to `smtpmail-queue-dir'." (delete-region (point-at-bol) (point-at-bol 2))) (write-region (point-min) (point-max) qfile)))) -;(defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer) +;; (defun smtpmail-via-smtp (host,port,sender,destination,smtpmail-text-buffer) (defun smtpmail-fqdn () (if smtpmail-local-domain @@ -504,13 +507,7 @@ This is relative to `smtpmail-queue-dir'." (defun smtpmail-open-stream (process-buffer host port) (let ((cred (smtpmail-find-credentials smtpmail-starttls-credentials host port))) - (if (null (and cred (condition-case () - (with-no-warnings - (require 'starttls) - (call-process (if starttls-use-gnutls - starttls-gnutls-program - starttls-program))) - (error nil)))) + (if (null (and cred (starttls-any-program-available))) ;; The normal case. (open-network-stream "SMTP" process-buffer host port) (let* ((cred-key (smtpmail-cred-key cred)) @@ -535,23 +532,32 @@ This is relative to `smtpmail-queue-dir'." (list "--x509keyfile" cred-key "--x509certfile" cred-cert))))) (starttls-open-stream "SMTP" process-buffer host port))))) -;; password-read autoloads password-cache. +;; `password-read' autoloads password-cache. (declare-function password-cache-add "password-cache" (key password)) (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 (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))) + (mech (car (smtpmail-intersection mechs smtpmail-auth-supported))) + (auth-user (auth-source-user-or-password + "login" host (or port "smtp"))) + (auth-pass (auth-source-user-or-password + "password" host (or port "smtp"))) + (cred (if (and auth-user auth-pass) ; try user-auth-* before netrc-* + (list host port auth-user auth-pass) + ;; else, if auth-source didn't return them... + (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")))) + ;; else, try `smtpmail-find-credentials' since + ;; `smtpmail-auth-credentials' is not a string + (smtpmail-find-credentials + smtpmail-auth-credentials host port)))) (prompt (when cred (format "SMTP password for %s:%s: " (smtpmail-cred-server cred) (smtpmail-cred-port cred)))) @@ -580,7 +586,7 @@ This is relative to `smtpmail-queue-dir'." ;; In my case, the response string is 80 characters ;; long. Without the no-line-break option for - ;; base64-encode-sting, only the first 76 characters + ;; `base64-encode-string', only the first 76 characters ;; are taken as a response to the server, and the ;; authentication fails. (encoded (base64-encode-string response t))) @@ -635,7 +641,7 @@ 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 + ;; `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 @@ -672,61 +678,60 @@ This is relative to `smtpmail-queue-dir'." (if (or (null (car (setq greeting (smtpmail-read-response process)))) (not (integerp (car greeting))) (>= (car greeting) 400)) - (throw 'done nil) - ) + (throw 'done nil)) (let ((do-ehlo t) (do-starttls t)) (while do-ehlo - ;; EHLO - (smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn))) - - (if (or (null (car (setq response-code - (smtpmail-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (progn - ;; HELO - (smtpmail-send-command - process (format "HELO %s" (smtpmail-fqdn))) - - (if (or (null (car (setq response-code - (smtpmail-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil))) - (dolist (line (cdr (cdr response-code))) - (let ((name - (with-case-table ascii-case-table - (mapcar (lambda (s) (intern (downcase s))) - (split-string (substring line 4) "[ ]"))))) - (and (eq (length name) 1) - (setq name (car name))) - (and name - (cond ((memq (if (consp name) (car name) name) - '(verb xvrb 8bitmime onex xone - expn size dsn etrn - enhancedstatuscodes - help xusr - auth=login auth starttls)) - (setq supported-extensions - (cons name supported-extensions))) - (smtpmail-warn-about-unknown-extensions - (message "Unknown extension %s" name))))))) - - (if (and do-starttls - (smtpmail-find-credentials smtpmail-starttls-credentials host port) - (member 'starttls supported-extensions) - (numberp (process-id process))) - (progn - (smtpmail-send-command process (format "STARTTLS")) - (if (or (null (car (setq response-code (smtpmail-read-response process)))) - (not (integerp (car response-code))) - (>= (car response-code) 400)) - (throw 'done nil)) - (starttls-negotiate process) - (setq do-starttls nil)) - (setq do-ehlo nil)))) + ;; EHLO + (smtpmail-send-command process (format "EHLO %s" (smtpmail-fqdn))) + + (if (or (null (car (setq response-code + (smtpmail-read-response process)))) + (not (integerp (car response-code))) + (>= (car response-code) 400)) + (progn + ;; HELO + (smtpmail-send-command + process (format "HELO %s" (smtpmail-fqdn))) + + (if (or (null (car (setq response-code + (smtpmail-read-response process)))) + (not (integerp (car response-code))) + (>= (car response-code) 400)) + (throw 'done nil))) + (dolist (line (cdr (cdr response-code))) + (let ((name + (with-case-table ascii-case-table + (mapcar (lambda (s) (intern (downcase s))) + (split-string (substring line 4) "[ ]"))))) + (and (eq (length name) 1) + (setq name (car name))) + (and name + (cond ((memq (if (consp name) (car name) name) + '(verb xvrb 8bitmime onex xone + expn size dsn etrn + enhancedstatuscodes + help xusr + auth=login auth starttls)) + (setq supported-extensions + (cons name supported-extensions))) + (smtpmail-warn-about-unknown-extensions + (message "Unknown extension %s" name))))))) + + (if (and do-starttls + (smtpmail-find-credentials smtpmail-starttls-credentials host port) + (member 'starttls supported-extensions) + (numberp (process-id process))) + (progn + (smtpmail-send-command process (format "STARTTLS")) + (if (or (null (car (setq response-code (smtpmail-read-response process)))) + (not (integerp (car response-code))) + (>= (car response-code) 400)) + (throw 'done nil)) + (starttls-negotiate process) + (setq do-starttls nil)) + (setq do-ehlo nil)))) (smtpmail-try-auth-methods process supported-extensions host port) @@ -786,7 +791,7 @@ This is relative to `smtpmail-queue-dir'." " BODY=8BITMIME" "") ""))) -; (smtpmail-send-command process (format "MAIL FROM:%s@%s" (user-login-name) (smtpmail-fqdn))) + ;; (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 size-part @@ -795,8 +800,7 @@ This is relative to `smtpmail-queue-dir'." (if (or (null (car (setq response-code (smtpmail-read-response process)))) (not (integerp (car response-code))) (>= (car response-code) 400)) - (throw 'done nil) - )) + (throw 'done nil))) ;; RCPT TO: (let ((n 0)) @@ -808,9 +812,7 @@ This is relative to `smtpmail-queue-dir'." (if (or (null (car response-code)) (not (integerp (car response-code))) (>= (car response-code) 400)) - (throw 'done nil) - ) - )) + (throw 'done nil)))) ;; DATA (smtpmail-send-command process "DATA") @@ -818,36 +820,33 @@ This is relative to `smtpmail-queue-dir'." (if (or (null (car (setq response-code (smtpmail-read-response process)))) (not (integerp (car response-code))) (>= (car response-code) 400)) - (throw 'done nil) - ) + (throw 'done nil)) ;; Mail contents (smtpmail-send-data process smtpmail-text-buffer) - ;;DATA end "." + ;; DATA end "." (smtpmail-send-command process ".") (if (or (null (car (setq response-code (smtpmail-read-response process)))) (not (integerp (car response-code))) (>= (car response-code) 400)) - (throw 'done nil) - ) - - ;;QUIT -; (smtpmail-send-command process "QUIT") -; (and (null (car (smtpmail-read-response process))) -; (throw 'done nil)) - t )) + (throw 'done nil)) + + ;; QUIT + ;; (smtpmail-send-command process "QUIT") + ;; (and (null (car (smtpmail-read-response process))) + ;; (throw 'done nil)) + t)) (if process (with-current-buffer (process-buffer process) (smtpmail-send-command process "QUIT") (smtpmail-read-response process) -; (if (or (null (car (setq response-code (smtpmail-read-response process)))) -; (not (integerp (car response-code))) -; (>= (car response-code) 400)) -; (throw 'done nil) -; ) + ;; (if (or (null (car (setq response-code (smtpmail-read-response process)))) + ;; (not (integerp (car response-code))) + ;; (>= (car response-code) 400)) + ;; (throw 'done nil)) (delete-process process) (unless smtpmail-debug-info (kill-buffer process-buffer))))))) @@ -935,8 +934,7 @@ This is relative to `smtpmail-queue-dir'." (if (eq (string-to-char data) ?.) (process-send-string process ".")) (process-send-string process data) - (process-send-string process "\r\n") - ) + (process-send-string process "\r\n")) (defun smtpmail-send-data (process buffer) (let ((data-continue t) sending-data) @@ -954,12 +952,11 @@ This is relative to `smtpmail-queue-dir'." (unwind-protect (with-current-buffer smtpmail-address-buffer (erase-buffer) - (let - ((case-fold-search t) - (simple-address-list "") - this-line - this-line-end - addr-regexp) + (let ((case-fold-search t) + (simple-address-list "") + this-line + this-line-end + addr-regexp) (insert-buffer-substring smtpmail-text-buffer header-start header-end) (goto-char (point-min)) ;; RESENT-* fields should stop processing of regular fields. @@ -980,13 +977,12 @@ This is relative to `smtpmail-queue-dir'." (setq this-line-end (point-marker)) (setq simple-address-list (concat simple-address-list " " - (mail-strip-quoted-names (buffer-substring this-line this-line-end)))) - ) + (mail-strip-quoted-names (buffer-substring this-line this-line-end))))) (erase-buffer) (insert " " simple-address-list "\n") - (subst-char-in-region (point-min) (point-max) 10 ? t);; newline --> blank - (subst-char-in-region (point-min) (point-max) ?, ? t);; comma --> blank - (subst-char-in-region (point-min) (point-max) 9 ? t);; tab --> blank + (subst-char-in-region (point-min) (point-max) 10 ? t) ; newline --> blank + (subst-char-in-region (point-min) (point-max) ?, ? t) ; comma --> blank + (subst-char-in-region (point-min) (point-max) 9 ? t) ; tab --> blank (goto-char (point-min)) ;; tidyness in case hook is not robust when it looks at this @@ -997,15 +993,8 @@ This is relative to `smtpmail-queue-dir'." (while (re-search-forward " \\([^ ]+\\) " (point-max) t) (backward-char 1) (setq recipient-address-list (cons (buffer-substring (match-beginning 1) (match-end 1)) - recipient-address-list)) - ) - (setq smtpmail-recipient-address-list recipient-address-list)) - - ) - ) - ) - ) - + recipient-address-list))) + (setq smtpmail-recipient-address-list recipient-address-list)))))) (defun smtpmail-do-bcc (header-end) "Delete [Resent-]BCC: and their continuation lines from the header area. @@ -1022,8 +1011,6 @@ many continuation lines." (while (and (looking-at "^[ \t].*\n") (< (point) header-end)) (replace-match "")))))) - (provide 'smtpmail) -;;; arch-tag: a76992df-6d71-43b7-9e72-4bacc6c05466 ;;; smtpmail.el ends here