Merge from origin/emacs-25

[gnu-emacs] / lisp / net / imap.el

diff --git a/lisp/net/imap.el b/lisp/net/imap.el
index cf19e6ca5cf891b263138611fc7240cc85a03b56..e5a14d75dee27103258188a6de00eb6e3b997c69 100644 (file)
--- a/lisp/net/imap.el
+++ b/lisp/net/imap.el
@@ -1,6 +1,6 @@
 ;;; imap.el --- imap library
 
 ;;; imap.el --- imap library
 

-;; Copyright (C) 1998-2014 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2016 Free Software Foundation, Inc.

 
 ;; Author: Simon Josefsson <simon@josefsson.org>
 ;; Keywords: mail
 
 ;; Author: Simon Josefsson <simon@josefsson.org>
 ;; Keywords: mail


@@ -74,8 +74,7 @@
 ;; imap.el supports RFC1730/2060/RFC3501 (IMAP4/IMAP4rev1).  The implemented
 ;; IMAP extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
 ;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS,
 ;; imap.el supports RFC1730/2060/RFC3501 (IMAP4/IMAP4rev1).  The implemented
 ;; IMAP extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
 ;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS,

-;; LOGINDISABLED) (with use of external library starttls.el and
-;; program starttls), and the GSSAPI / Kerberos V4 sections of RFC1731
+;; LOGINDISABLED), and the GSSAPI / Kerberos V4 sections of RFC1731

 ;; (with use of external program `imtest'), and RFC2971 (ID).  It also
 ;; takes advantage of the UNSELECT extension in Cyrus IMAPD.
 ;;
 ;; (with use of external program `imtest'), and RFC2971 (ID).  It also
 ;; takes advantage of the UNSELECT extension in Cyrus IMAPD.
 ;;


@@ -140,8 +139,6 @@
 (eval-and-compile
   ;; For Emacs <22.2 and XEmacs.
   (unless (fboundp 'declare-function) (defmacro declare-function (&rest _r)))
 (eval-and-compile
   ;; For Emacs <22.2 and XEmacs.
   (unless (fboundp 'declare-function) (defmacro declare-function (&rest _r)))

-  (autoload 'starttls-open-stream "starttls")
-  (autoload 'starttls-negotiate "starttls")

   (autoload 'sasl-find-mechanism "sasl")
   (autoload 'digest-md5-parse-digest-challenge "digest-md5")
   (autoload 'digest-md5-digest-response "digest-md5")
   (autoload 'sasl-find-mechanism "sasl")
   (autoload 'digest-md5-parse-digest-challenge "digest-md5")
   (autoload 'digest-md5-digest-response "digest-md5")


@@ -151,8 +148,7 @@
   (autoload 'utf7-encode "utf7")
   (autoload 'utf7-decode "utf7")
   (autoload 'format-spec "format-spec")
   (autoload 'utf7-encode "utf7")
   (autoload 'utf7-decode "utf7")
   (autoload 'format-spec "format-spec")

-  (autoload 'format-spec-make "format-spec")
-  (autoload 'open-tls-stream "tls"))
+  (autoload 'format-spec-make "format-spec"))

 
 ;; User variables.
 
 
 ;; User variables.
 


@@ -184,19 +180,6 @@ the list is tried until a successful connection is made."
   :group 'imap
   :type '(repeat string))
 
   :group 'imap
   :type '(repeat string))
 

-(defcustom imap-ssl-program '("openssl s_client -quiet -ssl3 -connect %s:%p"
-                             "openssl s_client -quiet -ssl2 -connect %s:%p"
-                             "s_client -quiet -ssl3 -connect %s:%p"
-                             "s_client -quiet -ssl2 -connect %s:%p")
-  "A string, or list of strings, containing commands for SSL connections.
-Within a string, %s is replaced with the server address and %p with
-port number on server.  The program should accept IMAP commands on
-stdin and return responses to stdout.  Each entry in the list is tried
-until a successful connection is made."
-  :group 'imap
-  :type '(choice string
-                (repeat string)))
-

 (defcustom imap-shell-program '("ssh %s imapd"
                                "rsh %s imapd"
                                "ssh %g ssh %s imapd"
 (defcustom imap-shell-program '("ssh %s imapd"
                                "rsh %s imapd"
                                "ssh %g ssh %s imapd"


@@ -293,7 +276,7 @@ Shorter values mean quicker response, but is more CPU intensive."
   '((gssapi    imap-gssapi-stream-p    imap-gssapi-open)
     (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open)
     (tls       imap-tls-p              imap-tls-open)
   '((gssapi    imap-gssapi-stream-p    imap-gssapi-open)
     (kerberos4 imap-kerberos4-stream-p imap-kerberos4-open)
     (tls       imap-tls-p              imap-tls-open)

-    (ssl       imap-ssl-p              imap-ssl-open)
+    (ssl       imap-tls-p              imap-tls-open)

     (network   imap-network-p          imap-network-open)
     (shell     imap-shell-p            imap-shell-open)
     (starttls  imap-starttls-p         imap-starttls-open))
     (network   imap-network-p          imap-network-open)
     (shell     imap-shell-p            imap-shell-open)
     (starttls  imap-starttls-p         imap-starttls-open))


@@ -453,7 +436,7 @@ second the status (OK, NO, BAD etc) of the command.")
 
 When non-nil, use an alternative UIDS form.  Enabling appears to
 be required for some servers (e.g., Microsoft Exchange 2007)
 
 When non-nil, use an alternative UIDS form.  Enabling appears to
 be required for some servers (e.g., Microsoft Exchange 2007)

-which otherwise would trigger a response 'BAD The specified
+which otherwise would trigger a response `BAD The specified

 message set is invalid.'.  We don't unconditionally use this
 form, since this is said to be significantly inefficient.
 
 message set is invalid.'.  We don't unconditionally use this
 form, since this is said to be significantly inefficient.
 


@@ -661,56 +644,6 @@ sure of changing the value of `foo'."
              nil)))))
     done))
 
              nil)))))
     done))
 

-(defun imap-ssl-p (_buffer)
-  nil)
-
-(defun imap-ssl-open (name buffer server port)
-  "Open an SSL connection to SERVER."
-  (let ((cmds (if (listp imap-ssl-program) imap-ssl-program
-               (list imap-ssl-program)))
-       cmd done)
-    (while (and (not done) (setq cmd (pop cmds)))
-      (message "imap: Opening SSL connection with `%s'..." cmd)
-      (erase-buffer)
-      (let* ((port (or port imap-default-ssl-port))
-            (coding-system-for-read imap-coding-system-for-read)
-            (coding-system-for-write imap-coding-system-for-write)
-            (process-connection-type imap-process-connection-type)
-            (set-process-query-on-exit-flag
-             (if (fboundp 'set-process-query-on-exit-flag)
-                 'set-process-query-on-exit-flag
-               'process-kill-without-query))
-            process)
-       (when (progn
-               (setq process (start-process
-                              name buffer shell-file-name
-                              shell-command-switch
-                              (format-spec cmd
-                                           (format-spec-make
-                                            ?s server
-                                            ?p (number-to-string port)))))
-               (funcall set-process-query-on-exit-flag process nil)
-               process)
-         (with-current-buffer buffer
-           (goto-char (point-min))
-           (while (and (memq (process-status process) '(open run))
-                       (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
-                       (goto-char (point-max))
-                       (forward-line -1)
-                       (not (imap-parse-greeting)))
-             (accept-process-output process 1)
-             (sit-for 1))
-           (imap-log buffer)
-           (erase-buffer)
-           (when (memq (process-status process) '(open run))
-             (setq done process))))))
-    (if done
-       (progn
-         (message "imap: Opening SSL connection with `%s'...done" cmd)
-         done)
-      (message "imap: Opening SSL connection with `%s'...failed" cmd)
-      nil)))
-

 (defun imap-tls-p (_buffer)
   nil)
 
 (defun imap-tls-p (_buffer)
   nil)
 


@@ -718,7 +651,8 @@ sure of changing the value of `foo'."
   (let* ((port (or port imap-default-tls-port))
         (coding-system-for-read imap-coding-system-for-read)
         (coding-system-for-write imap-coding-system-for-write)
   (let* ((port (or port imap-default-tls-port))
         (coding-system-for-read imap-coding-system-for-read)
         (coding-system-for-write imap-coding-system-for-write)

-        (process (open-tls-stream name buffer server port)))
+        (process (open-network-stream name buffer server port
+                                       :type 'tls)))

     (when process
       (while (and (memq (process-status process) '(open run))
                  ;; FIXME: Per the "blue moon" comment, the process/buffer
     (when process
       (while (and (memq (process-status process) '(open run))
                  ;; FIXME: Per the "blue moon" comment, the process/buffer


@@ -803,34 +737,29 @@ sure of changing the value of `foo'."
   (imap-capability 'STARTTLS buffer))
 
 (defun imap-starttls-open (name buffer server port)
   (imap-capability 'STARTTLS buffer))
 
 (defun imap-starttls-open (name buffer server port)

+  (message "imap: Connecting with STARTTLS...")

   (let* ((port (or port imap-default-port))
         (coding-system-for-read imap-coding-system-for-read)
         (coding-system-for-write imap-coding-system-for-write)
   (let* ((port (or port imap-default-port))
         (coding-system-for-read imap-coding-system-for-read)
         (coding-system-for-write imap-coding-system-for-write)

-        (process (starttls-open-stream name buffer server port))
-        done tls-info)
-    (message "imap: Connecting with STARTTLS...")
+        (process (open-network-stream
+                   name buffer server port
+                   :type 'starttls
+                   :capability-command "1 CAPABILITY\r\n"
+                   :always-query-capabilities t
+                   :end-of-command "\r\n"
+                   :success "^1 OK "
+                   :starttls-function
+                   #'(lambda (capabilities)
+                       (when (string-match-p "STARTTLS" capabilities)
+                         "1 STARTTLS\r\n"))))
+         done)

     (when process
     (when process

-      (while (and (memq (process-status process) '(open run))
-                 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
-                 (goto-char (point-max))
-                 (forward-line -1)
-                 (not (imap-parse-greeting)))
-       (accept-process-output process 1)
-       (sit-for 1))
-      (imap-send-command "STARTTLS")
-      (while (and (memq (process-status process) '(open run))
-                 (set-buffer buffer) ;; XXX "blue moon" nntp.el bug
-                 (goto-char (point-max))
-                 (forward-line -1)
-                 (not (re-search-forward "[0-9]+ OK.*\r?\n" nil t)))
-       (accept-process-output process 1)
-       (sit-for 1))

       (imap-log buffer)
       (imap-log buffer)

-      (when (and (setq tls-info (starttls-negotiate process))
-                (memq (process-status process) '(open run)))
-       (setq done process)))
-    (if (stringp tls-info)
-       (message "imap: STARTTLS info: %s" tls-info))
+      (when (memq (process-status process) '(open run))
+        (setq done process)
+        (with-current-buffer buffer
+          (goto-char (point-min))
+          (imap-parse-greeting))))

     (message "imap: Connecting with STARTTLS...%s" (if done "done" "failed"))
     done))
 
     (message "imap: Connecting with STARTTLS...%s" (if done "done" "failed"))
     done))
 


@@ -850,15 +779,16 @@ t if it successfully authenticates, nil otherwise."
       (while (or (not user) (not passwd))
        (setq user (or imap-username
                       (read-from-minibuffer
       (while (or (not user) (not passwd))
        (setq user (or imap-username
                       (read-from-minibuffer

-                       (concat "imap: username for " imap-server
-                               " (using stream `" (symbol-name imap-stream)
-                               "'): ")
+                       (format-message
+                        "imap: username for %s (using stream `%s'): "
+                        imap-server imap-stream)

                        (or user imap-default-user))))
                        (or user imap-default-user))))

-       (setq passwd (or imap-password
-                        (read-passwd
-                         (concat "imap: password for " user "@"
-                                 imap-server " (using authenticator `"
-                                 (symbol-name imap-auth) "'): "))))
+       (setq passwd
+             (or imap-password
+                 (read-passwd
+                  (format-message
+                   "imap: password for %s@%s (using authenticator `%s'): "
+                   user imap-server imap-auth))))

        (when (and user passwd)
          (if (funcall loginfunc user passwd)
              (progn
        (when (and user passwd)
          (if (funcall loginfunc user passwd)
              (progn


@@ -1563,8 +1493,8 @@ returned, if ITEMS is a symbol only its value is returned."
 (defun imap-mailbox-status-asynch (mailbox items &optional buffer)
   "Send status item requests ITEMS on MAILBOX to server in BUFFER.
 ITEMS can be a symbol or a list of symbols, valid symbols are one of
 (defun imap-mailbox-status-asynch (mailbox items &optional buffer)
   "Send status item requests ITEMS on MAILBOX to server in BUFFER.
 ITEMS can be a symbol or a list of symbols, valid symbols are one of

-the STATUS data items -- i.e. 'messages, 'recent, 'uidnext, 'uidvalidity
-or 'unseen.  The IMAP command tag is returned."
+the STATUS data items -- i.e., `messages', `recent', `uidnext', `uidvalidity'
+or `unseen'.  The IMAP command tag is returned."

   (with-current-buffer (or buffer (current-buffer))
     (imap-send-command (list "STATUS \""
                             (imap-utf7-encode mailbox)
   (with-current-buffer (or buffer (current-buffer))
     (imap-send-command (list "STATUS \""
                             (imap-utf7-encode mailbox)


@@ -2965,8 +2895,6 @@ Return nil if no complete line has arrived."
          imap-error-text
          imap-kerberos4s-p
          imap-kerberos4-open
          imap-error-text
          imap-kerberos4s-p
          imap-kerberos4-open

-         imap-ssl-p
-         imap-ssl-open

          imap-network-p
          imap-network-open
          imap-interactive-login
          imap-network-p
          imap-network-open
          imap-interactive-login