X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fimap.el;h=ed72d7b9ce0b10a2936bd027b29bb1fcade495c7;hb=729f45911d1ca333db712468f8af3924a852fb25;hp=871ea334bbe92552838bcff7509b4cd8b3a1779b;hpb=93c4442d2208942614bbe63688be90b90ec0571f;p=gnus

diff --git a/lisp/imap.el b/lisp/imap.el
index 871ea334b..ed72d7b9c 100644
--- a/lisp/imap.el
+++ b/lisp/imap.el
@@ -1,7 +1,7 @@
 ;;; imap.el --- imap library
 
 ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;;   2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
+;;   2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
 
 ;; Author: Simon Josefsson <simon@josefsson.org>
 ;; Keywords: mail
@@ -267,7 +267,7 @@ See also `imap-log'."
   :type 'string)
 
 (defcustom imap-read-timeout (if (string-match
-				  "windows-nt\\|os/2\\|emx\\|cygwin"
+				  "windows-nt\\|os/2\\|cygwin"
 				  (symbol-name system-type))
 				 1.0
 			       0.1)
@@ -380,6 +380,7 @@ basis.")
 (defvar imap-port nil)
 (defvar imap-username nil)
 (defvar imap-password nil)
+(defvar imap-last-authenticator nil)
 (defvar imap-calculate-literal-size-first nil)
 (defvar imap-state 'closed
   "IMAP state.
@@ -474,10 +475,10 @@ sure of changing the value of `foo'."
       (setcdr alist (imap-remassoc key (cdr alist)))
       alist)))
 
-(defsubst imap-disable-multibyte ()
+(defmacro imap-disable-multibyte ()
   "Enable multibyte in the current buffer."
-  (when (fboundp 'set-buffer-multibyte)
-    (set-buffer-multibyte nil)))
+  (unless (featurep 'xemacs)
+    '(set-buffer-multibyte nil)))
 
 (defsubst imap-utf7-encode (string)
   (if imap-use-utf7
@@ -514,6 +515,16 @@ sure of changing the value of `foo'."
 
 ;; Server functions; stream stuff:
 
+(defun imap-log (string-or-buffer)
+  (when imap-log
+    (with-current-buffer (get-buffer-create imap-log-buffer)
+      (imap-disable-multibyte)
+      (buffer-disable-undo)
+      (goto-char (point-max))
+      (if (bufferp string-or-buffer)
+	  (insert-buffer-substring string-or-buffer)
+	(insert string-or-buffer)))))
+
 (defun imap-kerberos4-stream-p (buffer)
   (imap-capability 'AUTH=KERBEROS_V4 buffer))
 
@@ -568,12 +579,6 @@ sure of changing the value of `foo'."
 				  (setq response (match-string 1)))))
 	      (accept-process-output process 1)
 	      (sit-for 1))
-	    (and imap-log
-		 (with-current-buffer (get-buffer-create imap-log-buffer)
-		   (imap-disable-multibyte)
-		   (buffer-disable-undo)
-		   (goto-char (point-max))
-		   (insert-buffer-substring buffer)))
 	    (erase-buffer)
 	    (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd
 		     (if response (concat "done, " response) "failed"))
@@ -644,12 +649,7 @@ sure of changing the value of `foo'."
 				  (setq response (match-string 1)))))
 	      (accept-process-output process 1)
 	      (sit-for 1))
-	    (and imap-log
-		 (with-current-buffer (get-buffer-create imap-log-buffer)
-		   (imap-disable-multibyte)
-		   (buffer-disable-undo)
-		   (goto-char (point-max))
-		   (insert-buffer-substring buffer)))
+	    (imap-log buffer)
 	    (erase-buffer)
 	    (message "GSSAPI IMAP connection: %s" (or response "failed"))
 	    (if (and response (let ((case-fold-search nil))
@@ -700,12 +700,7 @@ sure of changing the value of `foo'."
 			(not (imap-parse-greeting)))
 	      (accept-process-output process 1)
 	      (sit-for 1))
-	    (and imap-log
-		 (with-current-buffer (get-buffer-create imap-log-buffer)
-		   (imap-disable-multibyte)
-		   (buffer-disable-undo)
-		   (goto-char (point-max))
-		   (insert-buffer-substring buffer)))
+	    (imap-log buffer)
 	    (erase-buffer)
 	    (when (memq (process-status process) '(open run))
 	      (setq done process))))))
@@ -739,12 +734,7 @@ sure of changing the value of `foo'."
 		  (not (imap-parse-greeting)))
 	(accept-process-output process 1)
 	(sit-for 1))
-      (and imap-log
-	   (with-current-buffer (get-buffer-create imap-log-buffer)
-	     (imap-disable-multibyte)
-	     (buffer-disable-undo)
-	     (goto-char (point-max))
-	     (insert-buffer-substring buffer)))
+      (imap-log buffer)
       (when (memq (process-status process) '(open run))
 	process))))
 
@@ -763,12 +753,7 @@ sure of changing the value of `foo'."
 		  (not (imap-parse-greeting)))
 	(accept-process-output process 1)
 	(sit-for 1))
-      (and imap-log
-	   (with-current-buffer (get-buffer-create imap-log-buffer)
-	     (imap-disable-multibyte)
-	     (buffer-disable-undo)
-	     (goto-char (point-max))
-	     (insert-buffer-substring buffer)))
+      (imap-log buffer)
       (when (memq (process-status process) '(open run))
 	process))))
 
@@ -802,12 +787,7 @@ sure of changing the value of `foo'."
 		      (not (imap-parse-greeting)))
 	    (accept-process-output process 1)
 	    (sit-for 1))
-	  (and imap-log
-	       (with-current-buffer (get-buffer-create imap-log-buffer)
-		 (imap-disable-multibyte)
-		 (buffer-disable-undo)
-		 (goto-char (point-max))
-		 (insert-buffer-substring buffer)))
+	  (imap-log buffer)
 	  (erase-buffer)
 	  (when (memq (process-status process) '(open run))
 	    (setq done process)))))
@@ -844,11 +824,7 @@ sure of changing the value of `foo'."
 		  (not (re-search-forward "[0-9]+ OK.*\r?\n" nil t)))
 	(accept-process-output process 1)
 	(sit-for 1))
-      (and imap-log
-	   (with-current-buffer (get-buffer-create imap-log-buffer)
-	     (buffer-disable-undo)
-	     (goto-char (point-max))
-	     (insert-buffer-substring buffer)))
+      (imap-log buffer)
       (when (and (setq tls-info (starttls-negotiate process))
 		 (memq (process-status process) '(open run)))
 	(setq done process)))
@@ -872,25 +848,26 @@ Returns t if login was successful, nil otherwise."
       (while (or (not user) (not passwd))
 	(setq user (or imap-username
 		       (read-from-minibuffer
-			(concat "IMAP username for " imap-server
+			(concat "imap: username for " imap-server
 				" (using stream `" (symbol-name imap-stream)
 				"'): ")
 			(or user imap-default-user))))
 	(setq passwd (or imap-password
 			 (read-passwd
-			  (concat "IMAP password for " user "@"
+			  (concat "imap: password for " user "@"
 				  imap-server " (using authenticator `"
 				  (symbol-name imap-auth) "'): "))))
 	(when (and user passwd)
 	  (if (funcall loginfunc user passwd)
 	      (progn
+		(message "imap: Login successful...")
 		(setq ret t
 		      imap-username user)
 		(when (and (not imap-password)
 			   (or imap-store-password
-			       (y-or-n-p "Store password for this session? ")))
+			       (y-or-n-p "imap: Store password for this IMAP session? ")))
 		  (setq imap-password passwd)))
-	    (message "Login failed...")
+	    (message "imap: Login failed...")
 	    (setq passwd nil)
 	    (setq imap-password nil)
 	    (sit-for 1))))
@@ -1160,7 +1137,10 @@ necessary.  If nil, the buffer name is generated."
 				      buffer
 				    (buffer-name buffer))))
 			(kill-buffer buffer)
-			(rename-buffer name))
+			(rename-buffer name)
+			;; set the passed buffer to the current one,
+			;; so that (imap-opened buffer) later will work
+			(setq buffer (current-buffer)))
 		      (message "imap: Reconnecting with stream `%s'...done"
 			       stream)
 		      (setq imap-stream stream)
@@ -1173,6 +1153,7 @@ necessary.  If nil, the buffer name is generated."
 		(setq streams nil))))))
       (when (imap-opened buffer)
 	(setq imap-mailbox-data (make-vector imap-mailbox-prime 0)))
+      ;; (debug "opened+state+auth+buffer" (imap-opened buffer) imap-state imap-auth buffer)
       (when imap-stream
 	buffer))))
 
@@ -1217,25 +1198,32 @@ password is remembered in the buffer."
 	    (eq imap-state 'examine))
       (make-local-variable 'imap-username)
       (make-local-variable 'imap-password)
-      (if user (setq imap-username user))
-      (if passwd (setq imap-password passwd))
+      (make-local-variable 'imap-last-authenticator)
+      (when user (setq imap-username user))
+      (when passwd (setq imap-password passwd))
       (if imap-auth
-	  (and (funcall (nth 2 (assq imap-auth
-				     imap-authenticator-alist)) (current-buffer))
+	  (and (setq imap-last-authenticator
+		     (assq imap-auth imap-authenticator-alist))
+	       (funcall (nth 2 imap-last-authenticator) (current-buffer))
 	       (setq imap-state 'auth))
 	;; Choose authenticator.
 	(let ((auths imap-authenticators)
 	      auth)
 	  (while (setq auth (pop auths))
 	    ;; OK to use authenticator?
-	    (when (funcall (nth 1 (assq auth imap-authenticator-alist)) (current-buffer))
+	    (setq imap-last-authenticator
+		  (assq auth imap-authenticator-alist))
+	    (when (funcall (nth 1 imap-last-authenticator) (current-buffer))
 	      (message "imap: Authenticating to `%s' using `%s'..."
 		       imap-server auth)
 	      (setq imap-auth auth)
-	      (if (funcall (nth 2 (assq auth imap-authenticator-alist)) (current-buffer))
+	      (if (funcall (nth 2 imap-last-authenticator) (current-buffer))
 		  (progn
 		    (message "imap: Authenticating to `%s' using `%s'...done"
 			     imap-server auth)
+		    ;; set imap-state correctly on successful auth attempt
+		    (setq imap-state 'auth)
+		    ;; stop iterating through the authenticator list
 		    (setq auths nil))
 		(message "imap: Authenticating to `%s' using `%s'...failed"
 			 imap-server auth)))))
@@ -1689,7 +1677,7 @@ is non-nil return these properties."
 	 propname)))
 
 (defun imap-message-map (func propname &optional buffer)
-  "Map a function across each mailbox in `imap-message-data', returning a list."
+  "Map a function across each message in `imap-message-data', returning a list."
   (with-current-buffer (or buffer (current-buffer))
     (let (result)
       (mapatoms
@@ -1798,25 +1786,38 @@ However, UIDS here is a cons, where the car is the canonical form
 of the UIDS specification, and the cdr is the one which works with
 Exchange 2007 or, potentially, other buggy servers.
 See `imap-enable-exchange-bug-workaround'."
-  ;; We don't unconditionally use the alternative (valid) form, since
-  ;; this is said to be significantly inefficient.  The first time we
-  ;; get here for a given, we'll try the canonical form.  If we get
-  ;; the known error from the buggy server, set the flag
-  ;; buffer-locally (to account for connections to multiple servers),
-  ;; then re-try with the alternative UIDS spec.
+  ;; The first time we get here for a given, we'll try the canonical
+  ;; form.  If we get the known error from the buggy server, set the
+  ;; flag buffer-locally (to account for connections to multiple
+  ;; servers), then re-try with the alternative UIDS spec.  We don't
+  ;; unconditionally use the alternative form, since the
+  ;; currently-used alternatives are seriously inefficient with some
+  ;; servers (although they are valid).
+  ;;
+  ;; FIXME:  Maybe it would be cleaner to have a flag to not signal
+  ;; the error (which otherwise gives a message), and test
+  ;; `imap-failed-tags'.  Also, Other IMAP clients use other forms of
+  ;; request which work with Exchange, e.g. Claws does "UID FETCH 1:*
+  ;; (UID)" rather than "FETCH UID 1,*".  Is there a good reason not
+  ;; to do the same?
   (condition-case data
-      (imap-fetch (if imap-enable-exchange-bug-workaround
-		      (cdr uids)
-		    (car uids))
-		  props receive nouidfetch buffer)
+      ;; Binding `debug-on-error' allows us to get the error from
+      ;; `imap-parse-response' -- it's normally caught by Emacs around
+      ;; execution of a process filter.
+      (let ((debug-on-error t))
+	(imap-fetch (if imap-enable-exchange-bug-workaround
+			(cdr uids)
+		      (car uids))
+		    props receive nouidfetch buffer))
     (error
      (if (and (not imap-enable-exchange-bug-workaround)
-	      (string-match
-	       "The specified message set is invalid"
-	       (cadr data)))
+	      ;; This is the Exchange 2007 response.  It may be more
+	      ;; robust just to check for a BAD response to the
+	      ;; attempted fetch.
+	      (string-match "The specified message set is invalid"
+			    (cadr data)))
 	 (with-current-buffer (or buffer (current-buffer))
-	   (set (make-local-variable
-		 'imap-enable-exchange-bug-workaround)
+	   (set (make-local-variable 'imap-enable-exchange-bug-workaround)
 		t)
 	   (imap-fetch (cdr uids) props receive nouidfetch))
        (signal (car data) (cdr data))))))
@@ -1876,7 +1877,7 @@ first element.  The rest of list contains the saved articles' UIDs."
 	  (imap-message-data (make-vector 2 0)))
       (when (imap-mailbox-examine-1 mailbox)
 	(prog1
-	    (and (imap-fetch-safe '("*" "*:*") "UID")
+	    (and (imap-fetch-safe '("*" . "*:*") "UID")
 		 (list (imap-mailbox-get-1 'uidvalidity mailbox)
 		       (apply 'max (imap-message-map
 				    (lambda (uid prop) uid) 'UID))))
@@ -1933,12 +1934,7 @@ on failure."
 
 (defun imap-send-command-1 (cmdstr)
   (setq cmdstr (concat cmdstr imap-client-eol))
-  (and imap-log
-       (with-current-buffer (get-buffer-create imap-log-buffer)
-	 (imap-disable-multibyte)
-	 (buffer-disable-undo)
-	 (goto-char (point-max))
-	 (insert cmdstr)))
+  (imap-log cmdstr)
   (process-send-string imap-process cmdstr))
 
 (defun imap-send-command (command &optional buffer)
@@ -1976,13 +1972,7 @@ on failure."
 			     (stream imap-stream)
 			     (eol imap-client-eol))
 			 (with-current-buffer cmd
-			   (and imap-log
-				(with-current-buffer (get-buffer-create
-						      imap-log-buffer)
-				  (imap-disable-multibyte)
-				  (buffer-disable-undo)
-				  (goto-char (point-max))
-				  (insert-buffer-substring cmd)))
+			   (imap-log cmd)
 			   (process-send-region process (point-min)
 						(point-max)))
 			 (process-send-string process imap-client-eol))))
@@ -1991,10 +1981,11 @@ on failure."
 	       (imap-send-command-1 cmdstr)
 	       (setq cmdstr nil)
 	       (unwind-protect
-		   (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
-		       (setq command nil) ;; abort command if no cont-req
-		     (setq command (cons (funcall cmd imap-continuation)
-					 command)))
+		   (setq command
+			 (if (not (eq (imap-wait-for-tag tag) 'INCOMPLETE))
+			     nil ;; abort command if no cont-req
+			   (cons (funcall cmd imap-continuation)
+				 command)))
 		 (setq imap-continuation nil)))
 	      (t
 	       (error "Unknown command type"))))
@@ -2008,7 +1999,7 @@ on failure."
       (while (and (null imap-continuation)
 		  (memq (process-status imap-process) '(open run))
 		  (< imap-reached-tag tag))
-	(let ((len (/ (point-max) 1024))
+	(let ((len (/ (buffer-size) 1024))
 	      message-log-max)
 	  (unless (< len 10)
 	    (setq imap-have-messaged t)
@@ -2057,18 +2048,13 @@ Return nil if no complete line has arrived."
     (with-current-buffer (process-buffer proc)
       (goto-char (point-max))
       (insert string)
-      (and imap-log
-	   (with-current-buffer (get-buffer-create imap-log-buffer)
-	     (imap-disable-multibyte)
-	     (buffer-disable-undo)
-	     (goto-char (point-max))
-	     (insert string)))
+      (imap-log string)
       (let (end)
 	(goto-char (point-min))
 	(while (setq end (imap-find-next-line))
 	  (save-restriction
 	    (narrow-to-region (point-min) end)
-	    (delete-backward-char (length imap-server-eol))
+	    (delete-char (- (length imap-server-eol)))
 	    (goto-char (point-min))
 	    (unwind-protect
 		(cond ((eq imap-state 'initial)
@@ -2545,7 +2531,11 @@ Return nil if no complete line has arrived."
   (when (eq (char-after) ?\()
     (let (uid flags envelope internaldate rfc822 rfc822header rfc822text
 	      rfc822size body bodydetail bodystructure flags-empty)
-      (while (not (eq (char-after) ?\)))
+      ;; Courier can insert spurious blank characters which will
+      ;; confuse `read', so skip past them.
+      (while (let ((moved (skip-chars-forward " \t")))
+	       (prog1 (not (eq (char-after) ?\)))
+		 (unless (= moved 0) (backward-char))))
 	(imap-forward)
 	(let ((token (read (current-buffer))))
 	  (imap-forward)
@@ -3023,6 +3013,7 @@ Return nil if no complete line has arrived."
 	  imap-list-to-message-set
 	  imap-fetch-asynch
 	  imap-fetch
+	  imap-fetch-safe
 	  imap-message-put
 	  imap-message-get
 	  imap-message-map
@@ -3061,5 +3052,4 @@ Return nil if no complete line has arrived."
 
 (provide 'imap)
 
-;; arch-tag: 27369ed6-33e4-482f-96f1-8bb906ba70f7
 ;;; imap.el ends here