Patch by Ed L. Cashin to make gnus-move-split-methods move to

[gnus] / lisp / imap.el

diff --git a/lisp/imap.el b/lisp/imap.el
index be2e3ef..294ba76 100644 (file)
--- a/lisp/imap.el
+++ b/lisp/imap.el
@@ -75,11 +75,11 @@
 ;;
 ;; imap.el support RFC1730/2060 (IMAP4/IMAP4rev1), implemented IMAP
 ;; extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342
 ;;
 ;; imap.el support RFC1730/2060 (IMAP4/IMAP4rev1), implemented IMAP
 ;; extensions are RFC2195 (CRAM-MD5), RFC2086 (ACL), RFC2342

-;; (NAMESPACE), RFC2359 (UIDPLUS), the IMAP-part of RFC2595 (STARTTLS)
-;; (with use of external library starttls.el and program starttls) and
-;; the GSSAPI / kerberos V4 sections of RFC1731 (with use of external
-;; program `imtest').  It also take advantage the UNSELECT extension
-;; in Cyrus IMAPD.
+;; (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
+;; (with use of external program `imtest').  It also take advantage
+;; the UNSELECT extension in Cyrus IMAPD.

 ;;
 ;; Without the work of John McClary Prevost and Jim Radford this library
 ;; would not have seen the light of day.  Many thanks.
 ;;
 ;; Without the work of John McClary Prevost and Jim Radford this library
 ;; would not have seen the light of day.  Many thanks.


@@ -246,7 +246,7 @@ stream.")
   "Priority of authenticators to consider when authenticating to server.")
 
 (defvar imap-authenticator-alist 
   "Priority of authenticators to consider when authenticating to server.")
 
 (defvar imap-authenticator-alist 

-  '((gssapi     imap-gssapi-auth-p    imap-gssapia-auth)
+  '((gssapi     imap-gssapi-auth-p    imap-gssapi-auth)

     (kerberos4  imap-kerberos4-auth-p imap-kerberos4-auth)
     (cram-md5   imap-cram-md5-p       imap-cram-md5-auth)
     (login      imap-login-p          imap-login-auth)
     (kerberos4  imap-kerberos4-auth-p imap-kerberos4-auth)
     (cram-md5   imap-cram-md5-p       imap-cram-md5-auth)
     (login      imap-login-p          imap-login-auth)


@@ -435,6 +435,7 @@ If ARGS, PROMPT is used as an argument to `format'."
        cmd done)
     (while (and (not done) (setq cmd (pop cmds)))
       (message "Opening Kerberos 4 IMAP connection with `%s'..." cmd)
        cmd done)
     (while (and (not done) (setq cmd (pop cmds)))
       (message "Opening Kerberos 4 IMAP connection with `%s'..." cmd)

+      (erase-buffer)

       (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)


@@ -478,7 +479,8 @@ If ARGS, PROMPT is used as an argument to `format'."
                   (goto-char (point-max))
                   (insert-buffer-substring buffer)))
            (erase-buffer)
                   (goto-char (point-max))
                   (insert-buffer-substring buffer)))
            (erase-buffer)

-           (message "Kerberos 4 IMAP connection: %s" (or response "failed"))
+           (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd
+                    (if response (concat "done, " response) "failed"))

            (if (and response (let ((case-fold-search nil))
                                (not (string-match "failed" response))))
                (setq done process)
            (if (and response (let ((case-fold-search nil))
                                (not (string-match "failed" response))))
                (setq done process)


@@ -513,6 +515,10 @@ If ARGS, PROMPT is used as an argument to `format'."
            (setq imap-client-eol "\n")
            (while (and (memq (process-status process) '(open run))
                        (goto-char (point-min))
            (setq imap-client-eol "\n")
            (while (and (memq (process-status process) '(open run))
                        (goto-char (point-min))

+                        ;; cyrus 1.6.x (13? < x <= 22) queries capabilities
+                       (or (while (looking-at "^C:")
+                             (forward-line))
+                           t)

                        ;; cyrus 1.6 imtest print "S: " before server greeting
                        (or (not (looking-at "S: "))
                            (forward-char 3)
                        ;; cyrus 1.6 imtest print "S: " before server greeting
                        (or (not (looking-at "S: "))
                            (forward-char 3)


@@ -584,7 +590,7 @@ If ARGS, PROMPT is used as an argument to `format'."
        (progn
          (message "imap: Opening SSL connection with `%s'...done" cmd)
          done)
        (progn
          (message "imap: Opening SSL connection with `%s'...done" cmd)
          done)

-      (message "imap: Failed opening SSL connection")
+         (message "imap: Opening SSL connection with `%s'...failed" cmd)

       nil)))
 
 (defun imap-network-p (buffer)
       nil)))
 
 (defun imap-network-p (buffer)


@@ -650,20 +656,24 @@ If ARGS, PROMPT is used as an argument to `format'."
        (progn
          (message "imap: Opening IMAP connection with `%s'...done" cmd)
          done)
        (progn
          (message "imap: Opening IMAP connection with `%s'...done" cmd)
          done)

-      (message "imap: Failed opening IMAP connection")
+         (message "imap: Opening IMAP connection with `%s'...failed" cmd)

       nil)))
 
 (defun imap-starttls-p (buffer)
       nil)))
 
 (defun imap-starttls-p (buffer)

-  (and (condition-case ()
-          (require 'starttls)
-        (error nil))
-       (imap-capability 'STARTTLS buffer)))
+  (and (imap-capability 'STARTTLS buffer)
+       (condition-case ()
+          (progn
+            (require 'starttls)
+            (call-process "starttls"))
+        (error nil))))

 
 (defun imap-starttls-open (name buffer server port)
   (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)
 
 (defun imap-starttls-open (name buffer server port)
   (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)))
+        (process (starttls-open-stream name buffer server port))
+        done)
+    (message "imap: Connecting with STARTTLS...")

     (when process
       (while (and (memq (process-status process) '(open run))
                  (goto-char (point-min))
     (when process
       (while (and (memq (process-status process) '(open run))
                  (goto-char (point-min))


@@ -684,7 +694,13 @@ If ARGS, PROMPT is used as an argument to `format'."
                (starttls-negotiate imap-process)))
          (set-process-filter imap-process nil)))
       (when (memq (process-status process) '(open run))
                (starttls-negotiate imap-process)))
          (set-process-filter imap-process nil)))
       (when (memq (process-status process) '(open run))

-       process))))
+       (setq done process)))
+    (if done
+       (progn
+         (message "imap: Connecting with STARTTLS...done")
+         done)
+      (message "imap: Connecting with STARTTLS...failed")
+      nil)))

   
 ;; Server functions; authenticator stuff:
 
   
 ;; Server functions; authenticator stuff:
 


@@ -730,12 +746,16 @@ Returns t if login was successful, nil otherwise."
   (imap-capability 'AUTH=GSSAPI buffer))
 
 (defun imap-gssapi-auth (buffer)
   (imap-capability 'AUTH=GSSAPI buffer))
 
 (defun imap-gssapi-auth (buffer)

+  (message "imap: Authenticating using GSSAPI...%s"
+          (if (eq imap-stream 'gssapi) "done" "failed"))

   (eq imap-stream 'gssapi))
 
 (defun imap-kerberos4-auth-p (buffer)
   (imap-capability 'AUTH=KERBEROS_V4 buffer))
 
 (defun imap-kerberos4-auth (buffer)
   (eq imap-stream 'gssapi))
 
 (defun imap-kerberos4-auth-p (buffer)
   (imap-capability 'AUTH=KERBEROS_V4 buffer))
 
 (defun imap-kerberos4-auth (buffer)

+  (message "imap: Authenticating using Kerberos 4...%s"
+          (if (eq imap-stream 'kerberos4) "done" "failed"))

   (eq imap-stream 'kerberos4))
 
 (defun imap-cram-md5-p (buffer)
   (eq imap-stream 'kerberos4))
 
 (defun imap-cram-md5-p (buffer)


@@ -743,25 +763,33 @@ Returns t if login was successful, nil otherwise."
 
 (defun imap-cram-md5-auth (buffer)
   "Login to server using the AUTH CRAM-MD5 method."
 
 (defun imap-cram-md5-auth (buffer)
   "Login to server using the AUTH CRAM-MD5 method."

-  (imap-interactive-login
-   buffer
-   (lambda (user passwd)
-     (imap-ok-p
-      (imap-send-command-wait
-       (list
-       "AUTHENTICATE CRAM-MD5"
-       (lambda (challenge)
-         (let* ((decoded (base64-decode-string challenge))
-                (hash (rfc2104-hash 'md5 64 16 passwd decoded))
-                (response (concat user " " hash))
-                (encoded (base64-encode-string response)))
-           encoded))))))))
+  (message "imap: Authenticating using CRAM-MD5...")
+  (let ((done (imap-interactive-login
+              buffer
+              (lambda (user passwd)
+                (imap-ok-p
+                 (imap-send-command-wait
+                  (list
+                   "AUTHENTICATE CRAM-MD5"
+                   (lambda (challenge)
+                     (let* ((decoded (base64-decode-string challenge))
+                            (hash (rfc2104-hash 'md5 64 16 passwd decoded))
+                            (response (concat user " " hash))
+                            (encoded (base64-encode-string response)))
+                       encoded)))))))))
+    (if done
+       (message "imap: Authenticating using CRAM-MD5...done")
+      (message "imap: Authenticating using CRAM-MD5...failed"))))
+      
+  

 
 (defun imap-login-p (buffer)
 
 (defun imap-login-p (buffer)

-  (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer)))
+  (and (not (imap-capability 'LOGINDISABLED buffer))
+       (not (imap-capability 'X-LOGIN-CMD-DISABLED buffer))))

 
 (defun imap-login-auth (buffer)
   "Login to server using the LOGIN command."
 
 (defun imap-login-auth (buffer)
   "Login to server using the LOGIN command."

+  (message "imap: Plaintext authentication...")

   (imap-interactive-login buffer 
                          (lambda (user passwd)
                            (imap-ok-p (imap-send-command-wait 
   (imap-interactive-login buffer 
                          (lambda (user passwd)
                            (imap-ok-p (imap-send-command-wait 


@@ -772,19 +800,21 @@ Returns t if login was successful, nil otherwise."
   t)
 
 (defun imap-anonymous-auth (buffer)
   t)
 
 (defun imap-anonymous-auth (buffer)

+  (message "imap: Loging in anonymously...")

   (with-current-buffer buffer
     (imap-ok-p (imap-send-command-wait
                (concat "LOGIN anonymous \"" (concat (user-login-name) "@" 
                                                     (system-name)) "\"")))))
 
 (defun imap-digest-md5-p (buffer)
   (with-current-buffer buffer
     (imap-ok-p (imap-send-command-wait
                (concat "LOGIN anonymous \"" (concat (user-login-name) "@" 
                                                     (system-name)) "\"")))))
 
 (defun imap-digest-md5-p (buffer)

-  (and (condition-case ()
+  (and (imap-capability 'AUTH=DIGEST-MD5 buffer)
+       (condition-case ()

           (require 'digest-md5)
           (require 'digest-md5)

-        (error nil))
-       (imap-capability 'AUTH=DIGEST-MD5 buffer)))
+        (error nil))))

 
 (defun imap-digest-md5-auth (buffer)
   "Login to server using the AUTH DIGEST-MD5 method."
 
 (defun imap-digest-md5-auth (buffer)
   "Login to server using the AUTH DIGEST-MD5 method."

+  (message "imap: Authenticating using DIGEST-MD5...")

   (imap-interactive-login
    buffer
    (lambda (user passwd)
   (imap-interactive-login
    buffer
    (lambda (user passwd)


@@ -855,37 +885,44 @@ necessery.  If nil, the buffer name is generated."
     (setq imap-port (or port imap-port))
     (setq imap-auth (or auth imap-auth))
     (setq imap-stream (or stream imap-stream))
     (setq imap-port (or port imap-port))
     (setq imap-auth (or auth imap-auth))
     (setq imap-stream (or stream imap-stream))

-    (when (let ((imap-stream (or imap-stream imap-default-stream)))
-           (imap-open-1 buffer))
-      ;; Choose stream.
-      (let (stream-changed)
-       (when (null imap-stream)
-         (let ((streams imap-streams))
-           (while (setq stream (pop streams))
-             (if (funcall (nth 1 (assq stream imap-stream-alist)) buffer)
-                 (setq stream-changed (not (eq (or imap-stream 
-                                                   imap-default-stream)
-                                               stream))
-                       imap-stream stream
-                       streams nil)))
-           (unless imap-stream
-             (error "Couldn't figure out a stream for server"))))
-       (when stream-changed
-         (message "Reconnecting with %s..." imap-stream)
-         (imap-close buffer)
-         (imap-open-1 buffer)
-         (setq imap-capability nil)))
-      (if (imap-opened buffer)
-         ;; Choose authenticator
-         (when (and (null imap-auth) (not (eq imap-state 'auth)))
-           (let ((auths imap-authenticators))
-             (while (setq auth (pop auths))
-               (if (funcall (nth 1 (assq auth imap-authenticator-alist)) 
-                            buffer)
-                   (setq imap-auth auth
-                         auths nil)))
-             (unless imap-auth
-               (error "Couldn't figure out authenticator for server"))))))
+    (message "imap: Connecting to %s..." imap-server)
+    (if (let ((imap-stream (or imap-stream imap-default-stream)))
+         (imap-open-1 buffer))
+       ;; Choose stream.
+       (let (stream-changed)
+         (message "imap: Connecting to %s...done" imap-server)
+         (when (null imap-stream)
+           (let ((streams imap-streams))
+             (while (setq stream (pop streams))
+               (if (funcall (nth 1 (assq stream imap-stream-alist)) buffer)
+                   (setq stream-changed (not (eq (or imap-stream 
+                                                     imap-default-stream)
+                                                 stream))
+                         imap-stream stream
+                         streams nil)))
+             (unless imap-stream
+               (error "Couldn't figure out a stream for server"))))
+         (when stream-changed
+           (message "imap: Reconnecting with stream `%s'..." imap-stream)
+           (imap-close buffer)
+           (if (imap-open-1 buffer)
+               (message "imap: Reconnecting with stream `%s'...done"
+                        imap-stream)
+             (message "imap: Reconnecting with stream `%s'...failed" 
+                      imap-stream))
+           (setq imap-capability nil))
+         (if (imap-opened buffer)
+             ;; Choose authenticator
+             (when (and (null imap-auth) (not (eq imap-state 'auth)))
+               (let ((auths imap-authenticators))
+                 (while (setq auth (pop auths))
+                   (if (funcall (nth 1 (assq auth imap-authenticator-alist)) 
+                                buffer)
+                       (setq imap-auth auth
+                             auths nil)))
+                 (unless imap-auth
+                   (error "Couldn't figure out authenticator for server"))))))
+      (message "imap: Connecting to %s...failed" imap-server))

     (when (imap-opened buffer)
       (setq imap-mailbox-data (make-vector imap-mailbox-prime 0))
       buffer)))
     (when (imap-opened buffer)
       (setq imap-mailbox-data (make-vector imap-mailbox-prime 0))
       buffer)))


@@ -1233,6 +1270,18 @@ returned, if ITEMS is a symbol only it's value is returned."
               (list list))
             ","))
 
               (list list))
             ","))
 

+(defun imap-range-to-message-set (range)
+  (mapconcat
+   (lambda (item)
+     (if (consp item)
+         (format "%d:%d"
+                 (car item) (cdr item))
+       (format "%d" item)))
+   (if (and (listp range) (not (listp (cdr range))))
+       (list range) ;; make (1 . 2) into ((1 . 2))
+     range)
+   ","))
+

 (defun imap-fetch-asynch (uids props &optional nouidfetch buffer)
   (with-current-buffer (or buffer (current-buffer))
     (imap-send-command (format "%sFETCH %s %s" (if nouidfetch "" "UID ")
 (defun imap-fetch-asynch (uids props &optional nouidfetch buffer)
   (with-current-buffer (or buffer (current-buffer))
     (imap-send-command (format "%sFETCH %s %s" (if nouidfetch "" "UID ")


@@ -1446,7 +1495,6 @@ on failure."
   "Return number of lines in article by looking at the mime bodystructure BODY."
   (if (listp body)
       (if (stringp (car body))
   "Return number of lines in article by looking at the mime bodystructure BODY."
   (if (listp body)
       (if (stringp (car body))

-          ;; upcase for bug in courier imap server

          (cond ((and (string= (upcase (car body)) "TEXT")
                      (numberp (nth 7 body)))
                 (nth 7 body))
          (cond ((and (string= (upcase (car body)) "TEXT")
                      (numberp (nth 7 body)))
                 (nth 7 body))


@@ -2164,11 +2212,15 @@ Return nil if no complete line has arrived."
 ;;                       ; revisions of this specification.
 
 (defun imap-parse-flag-list ()
 ;;                       ; revisions of this specification.
 
 (defun imap-parse-flag-list ()

-  (let ((str (buffer-substring (point) (search-forward ")" nil t)))
-       pos)
-    (while (setq pos (string-match "\\\\" str (and pos (+ 2 pos))))
-      (setq str (replace-match "\\\\" nil t str)))
-    (mapcar 'symbol-name (read str))))
+  (let (flag-list start)
+    (assert (eq (char-after) ?\())
+    (while (and (not (eq (char-after) ?\)))
+               (setq start (progn (imap-forward) (point)))
+               (> (skip-chars-forward "^ )" (gnus-point-at-eol)) 0))
+      (push (buffer-substring start (point)) flag-list))
+    (assert (eq (char-after) ?\)))
+    (imap-forward)
+    (nreverse flag-list)))

 
 ;;   envelope        = "(" env-date SP env-subject SP env-from SP env-sender SP
 ;;                     env-reply-to SP env-to SP env-cc SP env-bcc SP
 
 ;;   envelope        = "(" env-date SP env-subject SP env-from SP env-sender SP
 ;;                     env-reply-to SP env-to SP env-cc SP env-bcc SP


@@ -2226,7 +2278,10 @@ Return nil if no complete line has arrived."
           (imap-forward)
           (while (setq str (imap-parse-string))
             (push str strlist)
           (imap-forward)
           (while (setq str (imap-parse-string))
             (push str strlist)

-            (imap-forward))
+            ;; buggy stalker communigate pro 3.0 doesn't print SPC
+            ;; between body-fld-param's sometimes
+            (or (eq (char-after) ?\")
+                (imap-forward)))

           (nreverse strlist)))
        ((imap-parse-nil)
         nil)))
           (nreverse strlist)))
        ((imap-parse-nil)
         nil)))


@@ -2357,6 +2412,11 @@ Return nil if no complete line has arrived."
          (let (subbody)
            (while (and (eq (char-after) ?\()
                        (setq subbody (imap-parse-body)))
          (let (subbody)
            (while (and (eq (char-after) ?\()
                        (setq subbody (imap-parse-body)))

+             ;; buggy stalker communigate pro 3.0 insert a SPC between
+             ;; parts in multiparts
+             (when (and (eq (char-after) ?\ )
+                        (eq (char-after (1+ (point))) ?\())
+               (imap-forward))

              (push subbody body))
            (imap-forward)
            (push (imap-parse-string) body);; media-subtype
              (push subbody body))
            (imap-forward)
            (push (imap-parse-string) body);; media-subtype


@@ -2385,7 +2445,10 @@ Return nil if no complete line has arrived."
        (imap-forward)
        (push (imap-parse-nstring) body);; body-fld-desc
        (imap-forward)
        (imap-forward)
        (push (imap-parse-nstring) body);; body-fld-desc
        (imap-forward)

-       (push (imap-parse-string) body);; body-fld-enc
+       ;; next `or' for Sun SIMS bug, it regard body-fld-enc as a
+       ;; nstring and return NIL instead of defaulting back to 7BIT
+       ;; as the standard says.
+       (push (or (imap-parse-nstring) "7BIT") body);; body-fld-enc

        (imap-forward)
        (push (imap-parse-number) body);; body-fld-octets
 
        (imap-forward)
        (push (imap-parse-number) body);; body-fld-octets
 


@@ -2406,12 +2469,16 @@ Return nil if no complete line has arrived."
                   (push (imap-parse-envelope) body);; envelope
                   (imap-forward)
                   (push (imap-parse-body) body);; body
                   (push (imap-parse-envelope) body);; envelope
                   (imap-forward)
                   (push (imap-parse-body) body);; body

-                  (imap-forward)
-                  (push (imap-parse-number) body));; body-fld-lines
-                 ((setq lines (imap-parse-number));; body-type-text:
-                  (push lines body));; body-fld-lines
+                  ;; buggy stalker communigate pro 3.0 doesn't print
+                  ;; number of lines in message/rfc822 attachment
+                  (if (eq (char-after) ?\))
+                      (push 0 body)
+                    (imap-forward)
+                    (push (imap-parse-number) body))) ;; body-fld-lines
+                 ((setq lines (imap-parse-number))    ;; body-type-text:
+                  (push lines body))                  ;; body-fld-lines

                  (t
                  (t

-                  (backward-char)))));; no match...
+                  (backward-char)))))                 ;; no match...

 
        ;; ...and then parse the third one here...
 
 
        ;; ...and then parse the third one here...