Mercurial > emacs

changeset 32995:3720ccaca161

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
2000-10-27 Simon Josefsson <simon@josefsson.org> * nnimap.el (nnimap-group-overview-filename): Create directory for newfile (when use long filenames is nil). Copy+delete file if rename didn't work. (nnimap-group-overview-filename): `rename-file' and `copy-file' doesn't return anything useful, use ignore-errors instead. (nnimap-verify-uidvalidity): Delete overview file when uid validity changes. (nnimap-group-overview-filename): Store uidvalidity in filenames. Rename old files into new format. (nnimap-request-accept-article): Remove \n's from From_ lines. (nnimap-request-accept-article): Remove From[^:] lines. (imap-starttls-p): Check for starttls binary. (imap-starttls-open): More verbose. (imap-gssapi-auth): Ditto. (imap-kerberos4-auth): Ditto. (imap-cram-md5-auth): Ditto. (imap-login-auth): Ditto. (imap-anonymous-auth): Ditto. (imap-digest-md5-auth): Ditto. (imap-open): Ditto. (imap-digest-md5-p): Check capability first. (imap-parse-flag-list): Correctly parse empty lists. (imap-login-p): Support LOGINDISABLED. (imap-parse-body): Work around bug in Sun SIMS.
author Dave Love <fx@gnu.org>
date Fri, 27 Oct 2000 23:20:38 +0000
parents aa53b96ab835
children d4de00df3e68
files lisp/gnus/imap.el lisp/gnus/nnimap.el
diffstat 2 files changed, 173 insertions(+), 87 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/gnus/imap.el	Fri Oct 27 23:14:59 2000 +0000
+++ b/lisp/gnus/imap.el	Fri Oct 27 23:20:38 2000 +0000
@@ -75,11 +75,11 @@
 ;;
 ;; 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.
@@ -480,7 +480,8 @@
 		   (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)
@@ -590,7 +591,7 @@
 	(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)
@@ -656,20 +657,24 @@
 	(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)
-  (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)
-	 (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))
@@ -690,7 +695,13 @@
 		(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:
 
@@ -736,12 +747,16 @@
   (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)
+  (message "imap: Authenticating using Kerberos 4...%s"
+	   (if (eq imap-stream 'kerberos4) "done" "failed"))
   (eq imap-stream 'kerberos4))
 
 (defun imap-cram-md5-p (buffer)
@@ -749,25 +764,33 @@
 
 (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)
-  (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."
+  (message "imap: Plaintext authentication...")
   (imap-interactive-login buffer 
 			  (lambda (user passwd)
 			    (imap-ok-p (imap-send-command-wait 
@@ -778,19 +801,21 @@
   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)
-  (and (condition-case ()
+  (and (imap-capability 'AUTH=DIGEST-MD5 buffer)
+       (condition-case ()
 	   (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."
+  (message "imap: Authenticating using DIGEST-MD5...")
   (imap-interactive-login
    buffer
    (lambda (user passwd)
@@ -861,37 +886,44 @@
     (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)))
@@ -2182,14 +2214,14 @@
 
 (defun imap-parse-flag-list ()
   (let (flag-list start)
-    (when (eq (char-after) ?\()
-      (imap-forward)
-      (while (and (not (eq (char-before) ?\)))
-		  (setq start (point))
-		  (> (skip-chars-forward "^ )" (gnus-point-at-eol)) 0))
-	(push (buffer-substring start (point)) flag-list)
-	(imap-forward))
-      (nreverse flag-list))))
+    (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
@@ -2414,7 +2446,10 @@
 	(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
 
--- a/lisp/gnus/nnimap.el	Fri Oct 27 23:14:59 2000 +0000
+++ b/lisp/gnus/nnimap.el	Fri Oct 27 23:20:38 2000 +0000
@@ -323,10 +323,26 @@
 		     group (gnus-server-to-method
 			    (format "nnimap:%s" server))))
 	 (new-uidvalidity (imap-mailbox-get 'uidvalidity))
-	 (old-uidvalidity (gnus-group-get-parameter gnusgroup 'uidvalidity)))
+	 (old-uidvalidity (gnus-group-get-parameter gnusgroup 'uidvalidity))
+	 (dir (file-name-as-directory (expand-file-name nnimap-directory)))
+         (nameuid (nnheader-translate-file-chars
+                   (concat nnimap-nov-file-name
+                           (if (equal server "")
+                               "unnamed"
+                             server) "." group "." old-uidvalidity
+                             nnimap-nov-file-name-suffix) t))
+         (file (if (or nnmail-use-long-file-names
+		       (file-exists-p (expand-file-name nameuid dir)))
+		   (expand-file-name nameuid dir)
+		 (expand-file-name
+		  (mm-encode-coding-string
+		   (nnheader-replace-chars-in-string nameuid ?. ?/)
+		   nnmail-pathname-coding-system)
+		  dir))))
     (if old-uidvalidity
 	(if (not (equal old-uidvalidity new-uidvalidity))
-	    nil	;; uidvalidity clash
+	    ;; uidvalidity clash
+	    (gnus-delete-file file)
 	  (gnus-group-set-parameter gnusgroup 'uidvalidity new-uidvalidity)
 	  t)
       (gnus-group-add-parameter gnusgroup (cons 'uidvalidity new-uidvalidity))
@@ -442,18 +458,48 @@
 
 (defun nnimap-group-overview-filename (group server)
   "Make pathname for GROUP on SERVER."
-  (let ((dir (file-name-as-directory (expand-file-name nnimap-directory)))
-	(file (nnheader-translate-file-chars
-	       (concat nnimap-nov-file-name
-		       (if (equal server "")
-			   "unnamed"
-			 server) "." group nnimap-nov-file-name-suffix) t)))
-    (if (or nnmail-use-long-file-names
-	    (file-exists-p (concat dir file)))
-	(concat dir file)
-      (concat dir (mm-encode-coding-string
-		   (nnheader-replace-chars-in-string file ?. ?/)
-		   nnmail-pathname-coding-system)))))
+  (let* ((dir (file-name-as-directory (expand-file-name nnimap-directory)))
+         (uidvalidity (gnus-group-get-parameter
+                       (gnus-group-prefixed-name
+                        group (gnus-server-to-method
+                               (format "nnimap:%s" server)))
+                       'uidvalidity))
+         (name (nnheader-translate-file-chars
+                (concat nnimap-nov-file-name
+                        (if (equal server "")
+                            "unnamed"
+                          server) "." group nnimap-nov-file-name-suffix) t))
+         (nameuid (nnheader-translate-file-chars
+                   (concat nnimap-nov-file-name
+                           (if (equal server "")
+                               "unnamed"
+                             server) "." group "." uidvalidity
+                             nnimap-nov-file-name-suffix) t))
+         (oldfile (if (or nnmail-use-long-file-names
+                          (file-exists-p (expand-file-name name dir)))
+                      (expand-file-name name dir)
+                    (expand-file-name
+                     (mm-encode-coding-string
+                      (nnheader-replace-chars-in-string name ?. ?/)
+                      nnmail-pathname-coding-system)
+                     dir)))
+         (newfile (if (or nnmail-use-long-file-names
+                          (file-exists-p (expand-file-name nameuid dir)))
+                      (expand-file-name nameuid dir)
+                    (expand-file-name
+                     (mm-encode-coding-string
+                      (nnheader-replace-chars-in-string nameuid ?. ?/)
+                      nnmail-pathname-coding-system)
+                     dir))))
+    (when (and (file-exists-p oldfile) (not (file-exists-p newfile)))
+      (message "nnimap: Upgrading novcache filename...")
+      (sit-for 1)
+      (gnus-make-directory (file-name-directory newfile))
+      (unless (ignore-errors (rename-file oldfile newfile) t)
+	(if (ignore-errors (copy-file oldfile newfile) t)
+	    (delete-file oldfile)
+	  (error "Can't rename `%s' to `%s'" oldfile newfile))))
+    newfile))
 
 (defun nnimap-retrieve-headers-from-file (group server)
   (with-current-buffer nntp-server-buffer
@@ -1119,9 +1165,13 @@
 					     nnimap-current-move-article)
 					    group 'dontcreate nil
 					    nnimap-server-buffer))
-		  ;; turn into rfc822 format (\r\n eol's)
 		  (with-current-buffer (current-buffer)
 		    (goto-char (point-min))
+		    ;; remove any 'From blabla' lines, some IMAP servers
+		    ;; reject the entire message otherwise.
+		    (when (looking-at "^From[^:]")
+		      (kill-region (point) (progn (forward-line) (point))))
+		    ;; turn into rfc822 format (\r\n eol's)
 		    (while (search-forward "\n" nil t)
 		      (replace-match "\r\n")))
                   ;; this 'or' is for Cyrus server bug
@@ -1151,7 +1201,8 @@
 
 (defun nnimap-acl-get (mailbox server)
   (when (nnimap-possibly-change-server server)
-    (imap-mailbox-acl-get mailbox nnimap-server-buffer)))
+    (and (imap-capability 'ACL nnimap-server-buffer)
+	 (imap-mailbox-acl-get mailbox nnimap-server-buffer))))
 
 (defun nnimap-acl-edit (mailbox method old-acls new-acls)
   (when (nnimap-possibly-change-server (cadr method))