diff lisp/gnus/nnimap.el @ 110583:b6d2a63ad993

Merge changes made in Gnus trunk. nnimap.el: Implement partial IMAP article fetch. nnimap.el: Have nnimap not update the infos if it can't get info from the server. Implement functions for showing the complete articles. gnus-int.el (gnus-open-server): Don't query whether to go offline -- just do it. gnus-art.el (gnus-mime-delete-part): Fix plural for "byte" when there isn't a single byte. nndoc.el (nndoc-type-alist): Move mime-parts after mbox. Suggested by Jay Berkenbilt. mm-decode.el (mm-save-part): Allow saving to other directories the normal Emacs way. gnus-html.el (gnus-html-rescale-image): Use our defalias gnus-window-inside-pixel-edges. gnus-srvr.el (gnus-server-copy-server): Add documentation. gnus.texi (Using IMAP): Document the new nnimap. nnimap.el (nnimap-wait-for-response): Search further when we're not using streaming. gnus-int.el (gnus-check-server): Say what the error was when opening failed. nnheader.el (nnheader-get-report-string): New function. gnus-int.el (gnus-check-server): Use report-string. nnimap.el (nnimap-open-connection): Add more error reporting when nnimap fails early. gnus-start.el (gnus-get-unread-articles): Don't try to open failed servers twice. nnimap.el (nnimap-wait-for-response): Reversed logic in the nnimap-streaming test. gnus-art.el: Removed CTAN button stuff, which I don't think is very relevant any more. Remove NoCeM support, since nobody seems to use it any more. Remove earcon and gnus-audio. gnus.el (gnus): Silence gnus-load message. gnus-group.el (gnus-read-ephemeral-bug-group): Add the bug email address to the To list for easier response. gnus.texi (Connecting to an IMAP Server): Show how to use as primary method instead of secondary.

--- a/lisp/gnus/nnimap.el	Sun Sep 26 03:39:24 2010 +0200
+++ b/lisp/gnus/nnimap.el	Sun Sep 26 04:03:19 2010 +0000
@@ -62,22 +62,23 @@
 (defvoo nnimap-inbox nil
   "The mail box where incoming mail arrives and should be split out of.")
 
+(defvoo nnimap-split-methods nil
+  "How mail is split.
+Uses the same syntax as nnmail-split-methods")
+
 (defvoo nnimap-authenticator nil
   "How nnimap authenticate itself to the server.
 Possible choices are nil (use default methods) or `anonymous'.")
 
-(defvoo nnimap-fetch-partial-articles nil
-  "If non-nil, nnimap will fetch partial articles.
-If t, nnimap will fetch only the first part.  If a string, it
-will fetch all parts that have types that match that string.  A
-likely value would be \"text/\" to automatically fetch all
-textual parts.")
-
 (defvoo nnimap-expunge t
   "If non-nil, expunge articles after deleting them.
 This is always done if the server supports UID EXPUNGE, but it's
 not done by default on servers that doesn't support that command.")
 
+(defvoo nnimap-streaming t
+  "If non-nil, try to use streaming commands with IMAP servers.
+Switching this off will make nnimap slower, but it helps with
+some servers.")
 
 (defvoo nnimap-connection-alist nil)
 
@@ -110,8 +111,6 @@
     (download "gnus-download")
     (forward "gnus-forward")))
 
-(defvar nnimap-split-methods nil)
-
 (defun nnimap-buffer ()
   (nnimap-find-process-buffer nntp-server-buffer))
 
@@ -128,8 +127,7 @@
 	  (nnimap-article-ranges (gnus-compress-sequence articles))
 	  (format "(UID RFC822.SIZE BODYSTRUCTURE %s)"
 		  (format
-		   (if (member "IMAP4REV1"
-			       (nnimap-capabilities nnimap-object))
+		   (if (nnimap-ver4-p)
 		       "BODY.PEEK[HEADER.FIELDS %s]"
 		     "RFC822.HEADER.LINES %s")
 		   (append '(Subject From Date Message-Id
@@ -273,42 +271,50 @@
   (with-current-buffer (nnimap-make-process-buffer buffer)
     (let* ((coding-system-for-read 'binary)
 	   (coding-system-for-write 'binary)
+	   (port nil)
 	   (ports
 	    (cond
 	     ((eq nnimap-stream 'network)
 	      (open-network-stream
 	       "*nnimap*" (current-buffer) nnimap-address
-	       (or nnimap-server-port
-		   (if (netrc-find-service-number "imap")
-		       "imap"
-		     "143")))
+	       (setq port
+		     (or nnimap-server-port
+			 (if (netrc-find-service-number "imap")
+			     "imap"
+			   "143"))))
 	      '("143" "imap"))
 	     ((eq nnimap-stream 'shell)
 	      (nnimap-open-shell-stream
 	       "*nnimap*" (current-buffer) nnimap-address
-	       (or nnimap-server-port "imap"))
+	       (setq port (or nnimap-server-port "imap")))
 	      '("imap"))
 	     ((eq nnimap-stream 'starttls)
 	      (starttls-open-stream
 	       "*nnimap*" (current-buffer) nnimap-address
-	       (or nnimap-server-port "imap"))
+	       (setq port (or nnimap-server-port "imap")))
 	      '("imap"))
 	     ((eq nnimap-stream 'ssl)
 	      (open-tls-stream
 	       "*nnimap*" (current-buffer) nnimap-address
-	       (or nnimap-server-port
-		   (if (netrc-find-service-number "imaps")
-		       "imaps"
-		     "993")))
+	       (setq port
+		     (or nnimap-server-port
+			 (if (netrc-find-service-number "imaps")
+			     "imaps"
+			   "993"))))
 	      '("143" "993" "imap" "imaps"))))
 	   connection-result login-result credentials)
       (setf (nnimap-process nnimap-object)
 	    (get-buffer-process (current-buffer)))
-      (when (and (nnimap-process nnimap-object)
-		 (memq (process-status (nnimap-process nnimap-object))
-		       '(open run)))
+      (if (not (and (nnimap-process nnimap-object)
+		    (memq (process-status (nnimap-process nnimap-object))
+			  '(open run))))
+	  (nnheader-report 'nnimap "Unable to contact %s:%s via %s"
+			   nnimap-address port nnimap-stream)
 	(gnus-set-process-query-on-exit-flag (nnimap-process nnimap-object) nil)
-	(when (setq connection-result (nnimap-wait-for-connection))
+	(if (not (setq connection-result (nnimap-wait-for-connection)))
+	    (nnheader-report 'nnimap
+			     "%s" (buffer-substring
+				   (point) (line-end-position)))
 	  (when (eq nnimap-stream 'starttls)
 	    (nnimap-command "STARTTLS")
 	    (starttls-negotiate (nnimap-process nnimap-object)))
@@ -370,7 +376,7 @@
 (deffoo nnimap-request-article (article &optional group server to-buffer)
   (with-current-buffer nntp-server-buffer
     (let ((result (nnimap-possibly-change-group group server))
-	  parts)
+	  parts structure)
       (when (stringp article)
 	(setq article (nnimap-find-article-by-message-id group article)))
       (when (and result
@@ -378,36 +384,113 @@
 	(erase-buffer)
 	(with-current-buffer (nnimap-buffer)
 	  (erase-buffer)
-	  (when nnimap-fetch-partial-articles
-	    (if (eq nnimap-fetch-partial-articles t)
+	  (when gnus-fetch-partial-articles
+	    (if (eq gnus-fetch-partial-articles t)
 		(setq parts '(1))
 	      (nnimap-command "UID FETCH %d (BODYSTRUCTURE)" article)
 	      (goto-char (point-min))
 	      (when (re-search-forward "FETCH.*BODYSTRUCTURE" nil t)
-		(let ((structure (ignore-errors (read (current-buffer)))))
-		  (setq parts (nnimap-find-wanted-parts structure))))))
-	  (setq result
-		(nnimap-command
-		 (if (member "IMAP4REV1" (nnimap-capabilities nnimap-object))
-		     "UID FETCH %d BODY.PEEK[]"
-		   "UID FETCH %d RFC822.PEEK")
-		 article))
-	  ;; Check that we really got an article.
-	  (goto-char (point-min))
-	  (unless (looking-at "\\* [0-9]+ FETCH")
-	    (setq result nil)))
-	(let ((buffer (nnimap-find-process-buffer (current-buffer))))
-	  (when (car result)
-	    (with-current-buffer (or to-buffer nntp-server-buffer)
-	      (insert-buffer-substring buffer)
-	      (goto-char (point-min))
-	      (let ((bytes (nnimap-get-length)))
-		(delete-region (line-beginning-position)
-			       (progn (forward-line 1) (point)))
-		(goto-char (+ (point) bytes))
-		(delete-region (point) (point-max))
-		(nnheader-ms-strip-cr))
-	      (cons group article))))))))
+		(setq structure (ignore-errors (read (current-buffer)))
+		      parts (nnimap-find-wanted-parts structure)))))
+	  (when (if parts
+		    (nnimap-get-partial-article article parts structure)
+		  (nnimap-get-whole-article article))
+	    (let ((buffer (current-buffer)))
+	      (with-current-buffer (or to-buffer nntp-server-buffer)
+		(erase-buffer)
+		(insert-buffer-substring buffer)
+		(nnheader-ms-strip-cr)
+		(cons group article)))))))))
+
+(defun nnimap-get-whole-article (article)
+  (let ((result
+	 (nnimap-command
+	  (if (nnimap-ver4-p)
+	      "UID FETCH %d BODY.PEEK[]"
+	    "UID FETCH %d RFC822.PEEK")
+	  article)))
+    ;; Check that we really got an article.
+    (goto-char (point-min))
+    (unless (looking-at "\\* [0-9]+ FETCH")
+      (setq result nil))
+    (when result
+      (goto-char (point-min))
+      (let ((bytes (nnimap-get-length)))
+	(delete-region (line-beginning-position)
+		       (progn (forward-line 1) (point)))
+	(goto-char (+ (point) bytes))
+	(delete-region (point) (point-max)))
+      t)))
+
+(defun nnimap-ver4-p ()
+  (member "IMAP4REV1" (nnimap-capabilities nnimap-object)))
+
+(defun nnimap-get-partial-article (article parts structure)
+  (let ((result
+	 (nnimap-command
+	  "UID FETCH %d (%s %s)"
+	  article
+	  (if (nnimap-ver4-p)
+	      "BODY.PEEK[HEADER]"
+	    "RFC822.HEADER")
+	  (if (nnimap-ver4-p)
+	      (mapconcat (lambda (part)
+			   (format "BODY.PEEK[%s]" part))
+			 parts " ")
+	    (mapconcat (lambda (part)
+			 (format "RFC822.PEEK[%s]" part))
+		       parts " ")))))
+    (when result
+      (nnimap-convert-partial-article structure))))
+
+(defun nnimap-convert-partial-article (structure)
+  ;; First just skip past the headers.
+  (goto-char (point-min))
+  (let ((bytes (nnimap-get-length))
+	id parts)
+    ;; Delete "FETCH" line.
+    (delete-region (line-beginning-position)
+		   (progn (forward-line 1) (point)))
+    (goto-char (+ (point) bytes))
+    ;; Collect all the body parts.
+    (while (looking-at ".*BODY\\[\\([.0-9]+\\)\\]")
+      (setq id (match-string 1)
+	    bytes (nnimap-get-length))
+      (beginning-of-line)
+      (delete-region (point) (progn (forward-line 1) (point)))
+      (push (list id (buffer-substring (point) (+ (point) bytes)))
+	    parts)
+      (delete-region (point) (+ (point) bytes)))
+    ;; Delete trailing junk.
+    (delete-region (point) (point-max))
+    ;; Now insert all the parts again where they fit in the structure.
+    (nnimap-insert-partial-structure structure parts)
+    t))
+
+(defun nnimap-insert-partial-structure (structure parts &optional subp)
+  (let ((type (car (last structure 4)))
+	(boundary (cadr (member "BOUNDARY" (car (last structure 3))))))
+    (when subp
+      (insert (format "Content-type: multipart/%s; boundary=%S\n\n"
+		      (downcase type) boundary)))
+    (while (not (stringp (car structure)))
+      (insert "\n--" boundary "\n")
+      (if (consp (caar structure))
+	  (nnimap-insert-partial-structure (pop structure) parts t)
+	(let ((bit (pop structure)))
+	  (insert (format  "Content-type: %s/%s"
+			   (downcase (nth 0 bit))
+			   (downcase (nth 1 bit))))
+	  (if (member "CHARSET" (nth 2 bit))
+	      (insert (format
+		       "; charset=%S\n" (cadr (member "CHARSET" (nth 2 bit)))))
+	    (insert "\n"))
+	  (insert (format "Content-transfer-encoding: %s\n"
+			  (nth 5 bit)))
+	  (insert "\n")
+	  (when (assoc (nth 9 bit) parts)
+	    (insert (cadr (assoc (nth 9 bit) parts)))))))
+    (insert "\n--" boundary "--\n")))
 
 (defun nnimap-find-wanted-parts (structure)
   (message-flatten-list (nnimap-find-wanted-parts-1 structure "")))
@@ -423,13 +506,14 @@
 			   (number-to-string num)
 			 (format "%s.%s" prefix num)))
 		  parts)
-	  (let ((type (format "%s/%s" (nth 0 sub) (nth 1 sub))))
-	    (when (string-match nnimap-fetch-partial-articles type)
-	      (push (if (string= prefix "")
+	  (let ((type (format "%s/%s" (nth 0 sub) (nth 1 sub)))
+		(id (if (string= prefix "")
 			(number-to-string num)
-		      (format "%s.%s" prefix num))
-		    parts)))
-	  (incf num))))
+		      (format "%s.%s" prefix num))))
+	    (setcar (nthcdr 9 sub) id)
+	    (when (string-match gnus-fetch-partial-articles type)
+	      (push id parts))))
+	(incf num)))
     (nreverse parts)))
 
 (deffoo nnimap-request-group (group &optional server dont-check info)
@@ -777,7 +861,12 @@
 			  (nnimap-send-command "UID FETCH %d:* FLAGS" start)
 			  start
 			  (car elem))
-		    sequences))))
+		    sequences)))
+	  ;; Some servers apparently can't have many outstanding
+	  ;; commands, so throttle them.
+	  (when (and (not nnimap-streaming)
+		     (car sequences))
+	    (nnimap-wait-for-response (caar sequences))))
 	sequences))))
 
 (deffoo nnimap-finish-retrieve-group-infos (server infos sequences)
@@ -785,26 +874,26 @@
 	     (nnimap-possibly-change-group nil server))
     (with-current-buffer (nnimap-buffer)
       ;; Wait for the final data to trickle in.
-      (nnimap-wait-for-response (cadar sequences))
-      ;; Now we should have all the data we need, no matter whether
-      ;; we're QRESYNCING, fetching all the flags from scratch, or
-      ;; just fetching the last 100 flags per group.
-      (nnimap-update-infos (nnimap-flags-to-marks
-			    (nnimap-parse-flags
-			     (nreverse sequences)))
-			   infos)
-      ;; Finally, just return something resembling an active file in
-      ;; the nntp buffer, so that the agent can save the info, too.
-      (with-current-buffer nntp-server-buffer
-	(erase-buffer)
-	(dolist (info infos)
-	  (let* ((group (gnus-info-group info))
-		 (active (gnus-active group)))
-	    (when active
-	      (insert (format "%S %d %d y\n"
-			      (gnus-group-real-name group)
-			      (cdr active)
-			      (car active))))))))))
+      (when (nnimap-wait-for-response (cadar sequences))
+	;; Now we should have all the data we need, no matter whether
+	;; we're QRESYNCING, fetching all the flags from scratch, or
+	;; just fetching the last 100 flags per group.
+	(nnimap-update-infos (nnimap-flags-to-marks
+			      (nnimap-parse-flags
+			       (nreverse sequences)))
+			     infos)
+	;; Finally, just return something resembling an active file in
+	;; the nntp buffer, so that the agent can save the info, too.
+	(with-current-buffer nntp-server-buffer
+	  (erase-buffer)
+	  (dolist (info infos)
+	    (let* ((group (gnus-info-group info))
+		   (active (gnus-active group)))
+	      (when active
+		(insert (format "%S %d %d y\n"
+				(gnus-group-real-name group)
+				(cdr active)
+				(car active)))))))))))
 
 (defun nnimap-update-infos (flags infos)
   (dolist (info infos)
@@ -1045,17 +1134,22 @@
 	 (match-string 1))))
 
 (defun nnimap-wait-for-response (sequence &optional messagep)
-  (let ((process (get-buffer-process (current-buffer))))
+  (let ((process (get-buffer-process (current-buffer)))
+	openp)
     (goto-char (point-max))
-    (while (and (memq (process-status process)
-		      '(open run))
-		(not (re-search-backward (format "^%d .*\n" sequence)
-					 (max (point-min) (- (point) 500))
-					 t)))
+    (while (and (setq openp (memq (process-status process)
+				  '(open run)))
+		(not (re-search-backward
+		      (format "^%d .*\n" sequence)
+		      (if nnimap-streaming
+			  (max (point-min) (- (point) 500))
+			(point-min))
+		      t)))
       (when messagep
 	(message "Read %dKB" (/ (buffer-size) 1000)))
       (nnheader-accept-process-output process)
-      (goto-char (point-max)))))
+      (goto-char (point-max)))
+    openp))
 
 (defun nnimap-parse-response ()
   (let ((lines (split-string (nnimap-last-response-string) "\r\n" t))
@@ -1129,8 +1223,7 @@
     (nnimap-article-ranges articles)
     (format "(UID %s%s)"
 	    (format
-	     (if (member "IMAP4REV1"
-			 (nnimap-capabilities nnimap-object))
+	     (if (nnimap-ver4-p)
 		 "BODY.PEEK[HEADER] BODY.PEEK"
 	       "RFC822.PEEK"))
 	    (if nnimap-split-download-body-default