[Emacs-diffs] master ccedc67: * lisp/mail/smtpmail.el: Use lexical-binding and cl-generic

[Stefan Monnier]

branch: master
commit ccedc6797e041af35f00f2fa8fb45bffea5c3797
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>

    * lisp/mail/smtpmail.el: Use lexical-binding and cl-generic
    
    (smtpmail-auth-supported): Mark it as non-constant.
    (smtpmail-try-auth-methods): Remove unused var 'ret'.
    Test non-nullness of mech user and password before calling
    smtpmail-try-auth-method.
    (smtpmail-try-auth-method): Make it into a generic function.
    (smtpmail-via-smtp): Remove unused var 'response-code'.
---
 etc/NEWS              |   4 ++
 lisp/mail/smtpmail.el | 110 ++++++++++++++++++++++++++------------------------
 2 files changed, 61 insertions(+), 53 deletions(-)

diff --git a/etc/NEWS b/etc/NEWS
index f6f36df..26f8857 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -88,6 +88,10 @@ strings in non-text modes.
 
 * Changes in Specialized Modes and Packages in Emacs 27.1
 
+** Smtpmail
+Authentication mechanisms can be added via external packages, by
+defining new cl-defmethod of smtpmail-try-auth-method.
+
 ** Footnote-mode
 *** Support Hebrew-style footnotes
 *** Footnote text lines are now aligned.
diff --git a/lisp/mail/smtpmail.el b/lisp/mail/smtpmail.el
index 20cbeb5..186307f 100644
--- a/lisp/mail/smtpmail.el
+++ b/lisp/mail/smtpmail.el
@@ -1,4 +1,4 @@
-;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail
+;;; smtpmail.el --- simple SMTP protocol (RFC 821) for sending mail  -*- 
lexical-binding:t -*-
 
 ;; Copyright (C) 1995-1996, 2001-2018 Free Software Foundation, Inc.
 
@@ -138,7 +138,7 @@ The commands enables verbose information from the SMTP 
server."
 (defcustom smtpmail-code-conv-from nil
   "Coding system for encoding outgoing mail.
 Used for the value of `sendmail-coding-system' when
-`select-message-coding-system' is called. "
+`select-message-coding-system' is called."
   :type 'coding-system
   :group 'smtpmail)
 
@@ -179,9 +179,11 @@ This is relative to `smtpmail-queue-dir'."
 ;; Buffer-local variable.
 (defvar smtpmail-read-point)
 
-(defconst smtpmail-auth-supported '(cram-md5 plain login)
+(defvar smtpmail-auth-supported '(cram-md5 plain login)
   "List of supported SMTP AUTH mechanisms.
-The list is in preference order.")
+The list is in preference order.
+Every element should have a matching `cl-defmethod' for
+for `smtpmail-try-auth-method'.")
 
 (defvar smtpmail-mail-address nil
   "Value to use for envelope-from address for mail from ambient buffer.")
@@ -508,8 +510,7 @@ The list is in preference order.")
          (user (plist-get auth-info :user))
          (password (plist-get auth-info :secret))
         (save-function (and ask-for-password
-                            (plist-get auth-info :save-function)))
-        ret)
+                            (plist-get auth-info :save-function))))
     (when (functionp password)
       (setq password (funcall password)))
     (when (and user
@@ -530,7 +531,10 @@ The list is in preference order.")
     (when (functionp password)
       (setq password (funcall password)))
     (let ((result (catch 'done
-                   (smtpmail-try-auth-method process mech user password))))
+                    (if (and mech user password)
+                       (smtpmail-try-auth-method process mech user password)
+                      ;; No mechanism, or no credentials.
+                      mech))))
       (if (stringp result)
          (progn
            (auth-source-forget+ :host host :port port)
@@ -539,51 +543,52 @@ The list is in preference order.")
          (funcall save-function))
        result))))
 
-(defun smtpmail-try-auth-method (process mech user password)
-  (let (ret)
-    (cond
-     ((or (not mech)
-         (not user)
-         (not password))
-      ;; No mechanism, or no credentials.
-      mech)
-     ((eq mech 'cram-md5)
-      (setq ret (smtpmail-command-or-throw process "AUTH CRAM-MD5"))
-      (when (eq (car ret) 334)
-       (let* ((challenge (substring (cadr ret) 4))
-              (decoded (base64-decode-string challenge))
-              (hash (rfc2104-hash 'md5 64 16 password decoded))
-              (response (concat user " " hash))
-              ;; Osamu Yamane <address@hidden>:
-              ;; SMTP auth fails because the SMTP server identifies
-              ;; only the first part of the string (delimited by
-              ;; new line characters) as a response from the
-              ;; client, and the rest as distinct commands.
-
-              ;; In my case, the response string is 80 characters
-              ;; long.  Without the no-line-break option for
-              ;; `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)))
-         (smtpmail-command-or-throw process encoded))))
-     ((eq mech 'login)
-      (smtpmail-command-or-throw process "AUTH LOGIN")
-      (smtpmail-command-or-throw process (base64-encode-string user t))
-      (smtpmail-command-or-throw process (base64-encode-string password t)))
-     ((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-command-or-throw
-       process
-       (concat "AUTH PLAIN "
-              (base64-encode-string (concat "\0" user "\0" password) t))
-       235))
-     (t
-      (error "Mechanism %s not implemented" mech)))))
+(cl-defgeneric smtpmail-try-auth-method (_process mech _user _password)
+  "Perform authentication of type MECH for USER with PASSWORD.
+MECH should be one of the values in `smtpmail-auth-supported'.
+USER and PASSWORD should be non-nil."
+  (error "Mechanism %S not implemented" mech))
+
+(cl-defmethod smtpmail-try-auth-method
+  (process (_mech (eql cram-md5)) user password)
+  (let ((ret (smtpmail-command-or-throw process "AUTH CRAM-MD5")))
+    (when (eq (car ret) 334)
+      (let* ((challenge (substring (cadr ret) 4))
+            (decoded (base64-decode-string challenge))
+            (hash (rfc2104-hash 'md5 64 16 password decoded))
+            (response (concat user " " hash))
+            ;; Osamu Yamane <address@hidden>:
+            ;; SMTP auth fails because the SMTP server identifies
+            ;; only the first part of the string (delimited by
+            ;; new line characters) as a response from the
+            ;; client, and the rest as distinct commands.
+
+            ;; In my case, the response string is 80 characters
+            ;; long.  Without the no-line-break option for
+            ;; `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)))
+       (smtpmail-command-or-throw process encoded)))))
+
+(cl-defmethod smtpmail-try-auth-method
+  (process (_mech (eql login)) user password)
+  (smtpmail-command-or-throw process "AUTH LOGIN")
+  (smtpmail-command-or-throw process (base64-encode-string user t))
+  (smtpmail-command-or-throw process (base64-encode-string password t)))
+
+(cl-defmethod smtpmail-try-auth-method
+  (process (_mech (eql plain)) user password)
+  ;; 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-command-or-throw
+   process
+   (concat "AUTH PLAIN "
+          (base64-encode-string (concat "\0" user "\0" password) t))
+   235))
 
 (defun smtpmail-response-code (string)
   (when string
@@ -662,7 +667,6 @@ Returns an error if the server cannot be contacted."
               (and from
                    (cadr (mail-extract-address-components from))))
             (smtpmail-user-mail-address)))
-       response-code
        process-buffer
        result
        auth-mechanisms