X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/4e190b801d917b3c5080442c1daba38020c3fe8c..806b00cb5f5034343709319bc217059fa382df19:/lisp/mail/smtpmail.el diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el index cc46660712..edcc82011a 100644 --- a/lisp/mail/smtpmail.el +++ b/lisp/mail/smtpmail.el @@ -55,15 +55,12 @@ ;;; Code: (require 'sendmail) +(require 'auth-source) (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") (autoload 'password-read "password-cache") -(autoload 'auth-source-search "auth-source") ;;; (defgroup smtpmail nil @@ -89,6 +86,12 @@ The default value would be \"smtp\" or 25." :type '(choice (integer :tag "Port") (string :tag "Service")) :group 'smtpmail) +(defcustom smtpmail-smtp-user nil + "User name to use when looking up credentials." + :version "24.1" + :type '(choice (const nil) string) + :group 'smtpmail) + (defcustom smtpmail-local-domain nil "Local domain name without a host name. If the function `system-name' returns the full internet address, @@ -487,12 +490,13 @@ The list is in preference order.") (let* ((mechs (cdr-safe (assoc 'auth supported-extensions))) (mech (car (smtpmail-intersection mechs smtpmail-auth-supported))) (auth-source-creation-prompts - '((user . "SMTP user at %h: ") + '((user . "SMTP user name for %h: ") (secret . "SMTP password for %u@%h: "))) (auth-info (car (auth-source-search :host host :port port + :user smtpmail-smtp-user :max 1 :require (and ask-for-password '(:user :secret)) @@ -502,6 +506,8 @@ The list is in preference order.") (save-function (and ask-for-password (plist-get auth-info :save-function))) ret) + (when (functionp password) + (setq password (funcall password))) (when (and user (not password)) ;; The user has stored the user name, but not the password, so @@ -513,6 +519,7 @@ The list is in preference order.") :max 1 :host host :port port + :user smtpmail-smtp-user :require '(:user :secret) :create t)) password (plist-get auth-info :secret))) @@ -589,15 +596,17 @@ The list is in preference order.") (defun smtpmail-query-smtp-server () (let ((server (read-string "Outgoing SMTP mail server: ")) - (ports '(587 "smtp")) + (ports '("smtp" 587)) stream port) (when (and smtpmail-smtp-server (not (member smtpmail-smtp-server ports))) (push smtpmail-smtp-server ports)) (while (and (not smtpmail-smtp-server) (setq port (pop ports))) - (when (setq stream (ignore-errors - (open-network-stream "smtp" nil server port))) + (when (setq stream (condition-case () + (open-network-stream "smtp" nil server port) + (quit nil) + (error nil))) (customize-save-variable 'smtpmail-smtp-server server) (customize-save-variable 'smtpmail-smtp-service port) (delete-process stream))) @@ -618,8 +627,6 @@ The list is in preference order.") (and mail-specify-envelope-from (mail-envelope-from)) user-mail-address)) - (coding-system-for-read 'binary) - (coding-system-for-write 'binary) response-code process-buffer result @@ -638,21 +645,23 @@ The list is in preference order.") (erase-buffer)) ;; open the connection to the server - (setq result - (open-network-stream - "smtpmail" process-buffer host port - :type smtpmail-stream-type - :return-list t - :capability-command (format "EHLO %s\r\n" (smtpmail-fqdn)) - :end-of-command "^[0-9]+ .*\r\n" - :success "^2.*\n" - :always-query-capabilities t - :starttls-function - (lambda (capabilities) - (and (string-match "-STARTTLS" capabilities) - "STARTTLS\r\n")) - :client-certificate t - :use-starttls-if-possible t)) + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary)) + (setq result + (open-network-stream + "smtpmail" process-buffer host port + :type smtpmail-stream-type + :return-list t + :capability-command (format "EHLO %s\r\n" (smtpmail-fqdn)) + :end-of-command "^[0-9]+ .*\r\n" + :success "^2.*\n" + :always-query-capabilities t + :starttls-function + (lambda (capabilities) + (and (string-match "[ -]STARTTLS" capabilities) + "STARTTLS\r\n")) + :client-certificate t + :use-starttls-if-possible t))) ;; If we couldn't access the server at all, we give up. (unless (setq process (car result)) @@ -669,7 +678,7 @@ The list is in preference order.") (throw 'done (format "No greeting: %s" greeting))) (when (>= code 400) (throw 'done (format "Connection not allowed: %s" greeting)))) - + (with-current-buffer process-buffer (set-buffer-process-coding-system 'raw-text-unix 'raw-text-unix) (make-local-variable 'smtpmail-read-point) @@ -722,7 +731,7 @@ The list is in preference order.") (when (member 'xusr supported-extensions) (smtpmail-command-or-throw process (format "XUSR"))) - + ;; MAIL FROM: (let ((size-part (if (or (member 'size supported-extensions) @@ -761,11 +770,15 @@ The list is in preference order.") ) ((and auth-mechanisms (not ask-for-password) - (= (car result) 530)) + (eq (car result) 530)) ;; We got a "530 auth required", so we close and try ;; again, this time asking the user for a password. - (smtpmail-send-command process "QUIT") - (smtpmail-read-response process) + ;; We ignore any errors here, because some MTAs just + ;; close the connection immediately after giving the + ;; error message. + (ignore-errors + (smtpmail-send-command process "QUIT") + (smtpmail-read-response process)) (delete-process process) (setq process nil) (throw 'done @@ -788,6 +801,7 @@ The list is in preference order.") nil) ((and auth-mechanisms (not ask-for-password) + (integerp (car result)) (>= (car result) 550) (<= (car result) 554)) ;; We got a "550 relay not permitted" (or the like), @@ -825,7 +839,8 @@ The list is in preference order.") (defun smtpmail-process-filter (process output) (with-current-buffer (process-buffer process) (goto-char (point-max)) - (insert output))) + (insert output) + (set-marker (process-mark process) (point)))) (defun smtpmail-read-response (process) (let ((case-fold-search nil) @@ -881,8 +896,8 @@ The list is in preference order.") (defun smtpmail-send-command (process command) (goto-char (point-max)) - (if (= (aref command 0) ?P) - (insert "PASS \r\n") + (if (string-match "\\`AUTH [A-Z]+ " command) + (insert (match-string 0 command) "\r\n") (insert command "\r\n")) (setq smtpmail-read-point (point)) (process-send-string process command)