Mercurial > emacs

changeset 110369:fb6801a4089a

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge changes made in Gnus trunk. imap.el: Revert back to version cb950ed8ff3e0f40dac437a51b269166f9ffb60d, since some of the changes seem problematic. Fix up the w3m/curl dependencies. mm-decode.el (mm-text-html-renderer): Don't have gnus-article-html depend on curl, which isn't essential. gnus-html.el (gnus-html-schedule-image-fetching, gnus-html-prefetch-images): Check for curl before using it.
author Katsumi Yamaoka <yamaoka@jpl.org>
date Tue, 14 Sep 2010 23:14:44 +0000
parents ccf206bc1b3a
children a5feb0659965
files lisp/ChangeLog lisp/gnus/ChangeLog lisp/gnus/gnus-html.el lisp/gnus/mm-decode.el lisp/net/imap.el
diffstat 5 files changed, 232 insertions(+), 56 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/ChangeLog	Tue Sep 14 22:46:24 2010 +0000
+++ b/lisp/ChangeLog	Tue Sep 14 23:14:44 2010 +0000
@@ -1,3 +1,9 @@
+2010-09-14  Lars Magne Ingebrigtsen  <larsi@gnus.org>
+
+	* net/imap.el: Revert back to version
+	cb950ed8ff3e0f40dac437a51b269166f9ffb60d, since some of the changes
+	seem problematic.
+
 2010-09-14  Juanma Barranquero  <lekktu@gmail.com>
 
 	* obsolete/old-whitespace.el (whitespace-unload-function):
--- a/lisp/gnus/ChangeLog	Tue Sep 14 22:46:24 2010 +0000
+++ b/lisp/gnus/ChangeLog	Tue Sep 14 23:14:44 2010 +0000
@@ -1,3 +1,15 @@
+2010-09-14  Lars Magne Ingebrigtsen  <larsi@gnus.org>
+
+	* gnus-html.el (gnus-html-schedule-image-fetching)
+	(gnus-html-prefetch-images): Check for curl before using it.
+
+	* mm-decode.el (mm-text-html-renderer): Don't have gnus-article-html
+	depend on curl, which isn't essential.
+
+	* imap.el: Revert back to version
+	cb950ed8ff3e0f40dac437a51b269166f9ffb60d, since some of the changes
+	seem problematic.
+
 2010-09-14  Juanma Barranquero  <lekktu@gmail.com>
 
 	* gnus-registry.el (gnus-registry-install-shortcuts):
--- a/lisp/gnus/gnus-html.el	Tue Sep 14 22:46:24 2010 +0000
+++ b/lisp/gnus/gnus-html.el	Tue Sep 14 23:14:44 2010 +0000
@@ -288,18 +288,19 @@
 (defun gnus-html-schedule-image-fetching (buffer images)
   (gnus-message 8 "gnus-html-schedule-image-fetching: buffer %s, images %s"
                 buffer images)
-  (let* ((url (caar images))
-	 (process (start-process
-		   "images" nil "curl"
-		   "-s" "--create-dirs"
-		   "--location"
-		   "--max-time" "60"
-		   "-o" (gnus-html-image-id url)
-		   (mm-url-decode-entities-string url))))
-    (process-kill-without-query process)
-    (set-process-sentinel process 'gnus-html-curl-sentinel)
-    (gnus-set-process-plist process (list 'images images
-					  'buffer buffer))))
+  (when (executable-find "curl")
+    (let* ((url (caar images))
+	   (process (start-process
+		     "images" nil "curl"
+		     "-s" "--create-dirs"
+		     "--location"
+		     "--max-time" "60"
+		     "-o" (gnus-html-image-id url)
+		     (mm-url-decode-entities-string url))))
+      (process-kill-without-query process)
+      (set-process-sentinel process 'gnus-html-curl-sentinel)
+      (gnus-set-process-plist process (list 'images images
+					    'buffer buffer)))))
 
 (defun gnus-html-image-id (url)
   (expand-file-name (sha1 url) gnus-html-cache-directory))
@@ -441,7 +442,8 @@
 ;;;###autoload
 (defun gnus-html-prefetch-images (summary)
   (let (blocked-images urls)
-    (when (buffer-live-p summary)
+    (when (and (buffer-live-p summary)
+	       (executable-find "curl"))
       (with-current-buffer summary
 	(setq blocked-images gnus-blocked-images))
       (save-match-data
--- a/lisp/gnus/mm-decode.el	Tue Sep 14 22:46:24 2010 +0000
+++ b/lisp/gnus/mm-decode.el	Tue Sep 14 23:14:44 2010 +0000
@@ -105,9 +105,7 @@
 	 ,disposition ,description ,cache ,id))
 
 (defcustom mm-text-html-renderer
-  (cond ((and (executable-find "w3m")
-	      (executable-find "curl"))
-	 'gnus-article-html)
+  (cond ((executable-find "w3m") 'gnus-article-html)
 	((executable-find "links") 'links)
 	((executable-find "lynx") 'lynx)
 	((locate-library "w3") 'w3)
--- a/lisp/net/imap.el	Tue Sep 14 22:46:24 2010 +0000
+++ b/lisp/net/imap.el	Tue Sep 14 23:14:44 2010 +0000
@@ -448,6 +448,18 @@
 The function should take two arguments, the first the IMAP tag and the
 second the status (OK, NO, BAD etc) of the command.")
 
+(defvar imap-enable-exchange-bug-workaround nil
+  "Send FETCH UID commands as *:* instead of *.
+
+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
+message set is invalid.'.  We don't unconditionally use this
+form, since this is said to be significantly inefficient.
+
+This variable is set to t automatically per server if the
+canonical form fails.")
+
 
 ;; Utility functions:
 
@@ -1303,38 +1315,40 @@
 
 ;; Mailbox functions:
 
-(defun imap-mailbox-put (propname value &optional mailbox)
-  (if imap-mailbox-data
-      (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data)
-	   propname value)
-    (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s"
-	   propname value mailbox (current-buffer)))
-  t)
+(defun imap-mailbox-put (propname value &optional mailbox buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (if imap-mailbox-data
+	(put (intern (or mailbox imap-current-mailbox) imap-mailbox-data)
+	     propname value)
+      (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s"
+	     propname value mailbox (current-buffer)))
+    t))
 
 (defsubst imap-mailbox-get-1 (propname &optional mailbox)
   (get (intern-soft (or mailbox imap-current-mailbox) imap-mailbox-data)
        propname))
 
 (defun imap-mailbox-get (propname &optional mailbox buffer)
-  (with-current-buffer (or buffer (current-buffer))
-    (imap-mailbox-get-1 propname (or (imap-utf7-encode mailbox)
-				     imap-current-mailbox))))
+  (let ((mailbox (imap-utf7-encode mailbox)))
+    (with-current-buffer (or buffer (current-buffer))
+      (imap-mailbox-get-1 propname (or mailbox imap-current-mailbox)))))
 
-(defun imap-mailbox-map-1 (func &optional mailbox-decoder)
-  (let (result)
-    (mapatoms
-     (lambda (s)
-       (push (funcall func (if mailbox-decoder
-			       (funcall mailbox-decoder (symbol-name s))
-			     (symbol-name s))) result))
-     imap-mailbox-data)
-    result))
+(defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (let (result)
+      (mapatoms
+       (lambda (s)
+	 (push (funcall func (if mailbox-decoder
+				 (funcall mailbox-decoder (symbol-name s))
+			       (symbol-name s))) result))
+       imap-mailbox-data)
+      result)))
 
-(defun imap-mailbox-map (func)
+(defun imap-mailbox-map (func &optional buffer)
   "Map a function across each mailbox in `imap-mailbox-data', returning a list.
 Function should take a mailbox name (a string) as
 the only argument."
-  (imap-mailbox-map-1 func 'imap-utf7-decode))
+  (imap-mailbox-map-1 func 'imap-utf7-decode buffer))
 
 (defun imap-current-mailbox (&optional buffer)
   (with-current-buffer (or buffer (current-buffer))
@@ -1648,26 +1662,29 @@
 		    uids)
 	  (imap-message-get uids receive))))))
 
-(defun imap-message-put (uid propname value)
-  (if imap-message-data
-      (put (intern (number-to-string uid) imap-message-data)
-	   propname value)
-    (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s"
-	   uid propname value (current-buffer)))
-  t)
+(defun imap-message-put (uid propname value &optional buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (if imap-message-data
+	(put (intern (number-to-string uid) imap-message-data)
+	     propname value)
+      (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s"
+	     uid propname value (current-buffer)))
+    t))
 
-(defun imap-message-get (uid propname)
-  (get (intern-soft (number-to-string uid) imap-message-data)
-       propname))
+(defun imap-message-get (uid propname &optional buffer)
+  (with-current-buffer (or buffer (current-buffer))
+    (get (intern-soft (number-to-string uid) imap-message-data)
+	 propname)))
 
-(defun imap-message-map (func propname)
+(defun imap-message-map (func propname &optional buffer)
   "Map a function across each message in `imap-message-data', returning a list."
-  (let (result)
-    (mapatoms
-     (lambda (s)
-       (push (funcall func (get s 'UID) (get s propname)) result))
-     imap-message-data)
-    result))
+  (with-current-buffer (or buffer (current-buffer))
+    (let (result)
+      (mapatoms
+       (lambda (s)
+	 (push (funcall func (get s 'UID) (get s propname)) result))
+       imap-message-data)
+      result)))
 
 (defmacro imap-message-envelope-date (uid &optional buffer)
   `(with-current-buffer (or ,buffer (current-buffer))
@@ -1763,6 +1780,48 @@
 	 (format "String %s cannot be converted to a Lisp integer" number))
       number)))
 
+(defun imap-fetch-safe (uids props &optional receive nouidfetch buffer)
+  "Like `imap-fetch', but DTRT with Exchange 2007 bug.
+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'."
+  ;; 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
+      ;; 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)
+	      ;; 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)
+		t)
+	   (imap-fetch (cdr uids) props receive nouidfetch))
+       (signal (car data) (cdr data))))))
+
 (defun imap-message-copyuid-1 (mailbox)
   (if (imap-capability 'UIDPLUS)
       (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox))
@@ -1772,7 +1831,7 @@
 	  (imap-message-data (make-vector 2 0)))
       (when (imap-mailbox-examine-1 mailbox)
 	(prog1
-	    (and (imap-fetch "*:*" "UID")
+	    (and (imap-fetch-safe '("*" . "*:*") "UID")
 		 (list (imap-mailbox-get-1 'uidvalidity mailbox)
 		       (apply 'max (imap-message-map
 				    (lambda (uid prop) uid) 'UID))))
@@ -1818,7 +1877,7 @@
 	  (imap-message-data (make-vector 2 0)))
       (when (imap-mailbox-examine-1 mailbox)
 	(prog1
-	    (and (imap-fetch "*:*" "UID")
+	    (and (imap-fetch-safe '("*" . "*:*") "UID")
 		 (list (imap-mailbox-get-1 'uidvalidity mailbox)
 		       (apply 'max (imap-message-map
 				    (lambda (uid prop) uid) 'UID))))
@@ -2892,6 +2951,105 @@
 	(imap-forward)
 	(nreverse body)))))
 
+(when imap-debug			; (untrace-all)
+  (require 'trace)
+  (buffer-disable-undo (get-buffer-create imap-debug-buffer))
+  (mapc (lambda (f) (trace-function-background f imap-debug-buffer))
+	'(
+	  imap-utf7-encode
+	  imap-utf7-decode
+	  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-kerberos4a-p
+	  imap-kerberos4-auth
+	  imap-cram-md5-p
+	  imap-cram-md5-auth
+	  imap-login-p
+	  imap-login-auth
+	  imap-anonymous-p
+	  imap-anonymous-auth
+	  imap-open-1
+	  imap-open
+	  imap-opened
+	  imap-ping-server
+	  imap-authenticate
+	  imap-close
+	  imap-capability
+	  imap-namespace
+	  imap-send-command-wait
+	  imap-mailbox-put
+	  imap-mailbox-get
+	  imap-mailbox-map-1
+	  imap-mailbox-map
+	  imap-current-mailbox
+	  imap-current-mailbox-p-1
+	  imap-current-mailbox-p
+	  imap-mailbox-select-1
+	  imap-mailbox-select
+	  imap-mailbox-examine-1
+	  imap-mailbox-examine
+	  imap-mailbox-unselect
+	  imap-mailbox-expunge
+	  imap-mailbox-close
+	  imap-mailbox-create-1
+	  imap-mailbox-create
+	  imap-mailbox-delete
+	  imap-mailbox-rename
+	  imap-mailbox-lsub
+	  imap-mailbox-list
+	  imap-mailbox-subscribe
+	  imap-mailbox-unsubscribe
+	  imap-mailbox-status
+	  imap-mailbox-acl-get
+	  imap-mailbox-acl-set
+	  imap-mailbox-acl-delete
+	  imap-current-message
+	  imap-list-to-message-set
+	  imap-fetch-asynch
+	  imap-fetch
+	  imap-fetch-safe
+	  imap-message-put
+	  imap-message-get
+	  imap-message-map
+	  imap-search
+	  imap-message-flag-permanent-p
+	  imap-message-flags-set
+	  imap-message-flags-del
+	  imap-message-flags-add
+	  imap-message-copyuid-1
+	  imap-message-copyuid
+	  imap-message-copy
+	  imap-message-appenduid-1
+	  imap-message-appenduid
+	  imap-message-append
+	  imap-body-lines
+	  imap-envelope-from
+	  imap-send-command-1
+	  imap-send-command
+	  imap-wait-for-tag
+	  imap-sentinel
+	  imap-find-next-line
+	  imap-arrival-filter
+	  imap-parse-greeting
+	  imap-parse-response
+	  imap-parse-resp-text
+	  imap-parse-resp-text-code
+	  imap-parse-data-list
+	  imap-parse-fetch
+	  imap-parse-status
+	  imap-parse-acl
+	  imap-parse-flag-list
+	  imap-parse-envelope
+	  imap-parse-body-extension
+	  imap-parse-body
+	  )))
+
 (provide 'imap)
 
 ;;; imap.el ends here