X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fnnimap.el;h=4c3eaace1e44a1909c942e3604f2b180b9973556;hp=548b6ec355fc332a99479c2585ae1794d1ee6c27;hb=30c23a0564c6baaddad642373b5b9d48c8894350;hpb=df6ac45b952171e7e709c1b0bf23cc7346429f81

diff --git a/lisp/nnimap.el b/lisp/nnimap.el
index 548b6ec35..4c3eaace1 100644
--- a/lisp/nnimap.el
+++ b/lisp/nnimap.el
@@ -29,6 +29,11 @@
 (eval-and-compile
   (require 'nnheader))
 
+(eval-when-compile
+  (require 'cl))
+
+(require 'netrc)
+
 (nnoo-declare nnimap)
 
 (defvoo nnimap-address nil
@@ -43,6 +48,12 @@ it will default to `imap'.")
   "How nnimap will talk to the IMAP server.
 Values are `ssl' and `network'.")
 
+(defvoo nnimap-shell-program (if (boundp 'imap-shell-program)
+				 (if (listp imap-shell-program)
+				     (car imap-shell-program)
+				   imap-shell-program)
+			       "ssh %s imapd"))
+
 (defvoo nnimap-inbox nil
   "The mail box where incoming mail arrives and should be split out of.")
 
@@ -52,6 +63,9 @@ 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-connection-alist nil)
+
+(defvoo nnimap-current-infos nil)
+
 (defvar nnimap-process nil)
 
 (defvar nnimap-status-string "")
@@ -60,7 +74,7 @@ not done by default on servers that doesn't support that command.")
   "Internal variable with default value for `nnimap-split-download-body'.")
 
 (defstruct nnimap
-  group process commands capabilities)
+  group process commands capabilities select-result)
 
 (defvar nnimap-object nil)
 
@@ -80,11 +94,7 @@ not done by default on servers that doesn't support that command.")
 (defun nnimap-buffer ()
   (nnimap-find-process-buffer nntp-server-buffer))
 
-(defmacro nnimap-with-process-buffer (&rest body)
-  `(with-current-buffer (nnimap-find-process-buffer (current-buffer))
-     ,@body))
-
-(defun nnimap-retrieve-headers (articles &optional group server fetch-old)
+(deffoo nnimap-retrieve-headers (articles &optional group server fetch-old)
   (with-current-buffer nntp-server-buffer
     (erase-buffer)
     (when (nnimap-possibly-change-group group server)
@@ -95,9 +105,9 @@ not done by default on servers that doesn't support that command.")
 	 (nnimap-send-command
 	  "UID FETCH %s %s"
 	  (nnimap-article-ranges (gnus-compress-sequence articles))
-	  (format "(UID RFC822.SIZE %s)"
+	  (format "(UID RFC822.SIZE BODYSTRUCTURE %s)"
 		  (format
-		   (if (member "IMAP4rev1"
+		   (if (member "IMAP4REV1"
 			       (nnimap-capabilities nnimap-object))
 		       "BODY.PEEK[HEADER.FIELDS %s]"
 		     "RFC822.HEADER.LINES %s")
@@ -112,7 +122,7 @@ not done by default on servers that doesn't support that command.")
 
 (defun nnimap-transform-headers ()
   (goto-char (point-min))
-  (let (article bytes)
+  (let (article bytes lines)
     (block nil
       (while (not (eobp))
 	(while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)"))
@@ -120,11 +130,21 @@ not done by default on servers that doesn't support that command.")
 	  (when (eobp)
 	    (return)))
 	(setq article (match-string 1)
-	      bytes (nnimap-get-length))
+	      bytes (nnimap-get-length)
+	      lines nil)
+	(beginning-of-line)
+	(when (search-forward "BODYSTRUCTURE" (line-end-position) t)
+	  (let ((structure (ignore-errors (read (current-buffer)))))
+	    (while (and (consp structure)
+			(not (stringp (car structure))))
+	      (setq structure (car structure)))
+	    (setq lines (nth 7 structure))))
 	(delete-region (line-beginning-position) (line-end-position))
 	(insert (format "211 %s Article retrieved." article))
 	(forward-line 1)
 	(insert (format "Bytes: %d\n" bytes))
+	(when lines
+	  (insert (format "Lines: %s\n" lines)))
 	(re-search-forward "^\r$")
 	(delete-region (line-beginning-position) (line-end-position))
 	(insert ".")
@@ -150,7 +170,7 @@ not done by default on servers that doesn't support that command.")
 	 result))
       (mapconcat #'identity (nreverse result) ",")))))
 
-(defun nnimap-open-server (server &optional defs)
+(deffoo nnimap-open-server (server &optional defs)
   (if (nnimap-server-opened server)
       t
     (unless (assq 'nnimap-address defs)
@@ -172,40 +192,75 @@ not done by default on servers that doesn't support that command.")
     (push (list buffer (current-buffer)) nnimap-connection-alist)
     (current-buffer)))
 
+(defun nnimap-open-shell-stream (name buffer host port)
+  (let ((process (start-process name buffer shell-file-name
+				shell-command-switch
+				(format-spec
+				 nnimap-shell-program
+				 (format-spec-make
+				  ?s host
+				  ?p port)))))
+    process))
+
+(defun nnimap-credentials (address &rest ports)
+  (let (port credentials)
+    ;; Request the credentials from all ports, but only query on the
+    ;; last port if all the previous ones have failed.
+    (while (and (null credentials)
+		(setq port (pop ports)))
+      (setq credentials
+	    (auth-source-user-or-password
+	     '("login" "password") address port nil (null ports))))
+    credentials))
+
 (defun nnimap-open-connection (buffer)
   (with-current-buffer (nnimap-make-process-buffer buffer)
-    (let ((credentials
-	   (cond
-	    ((eq nnimap-stream 'network)
-	     (open-network-stream "*nnimap*" (current-buffer) nnimap-address
-				  (or nnimap-server-port "imap"))
-	     (netrc-credentials nnimap-address "imap"))
-	    ((eq nnimap-stream 'ssl)
-	     (open-tls-stream "*nnimap*" (current-buffer) nnimap-address
-			      (or nnimap-server-port "imaps"))
-	     (netrc-credentials nnimap-address "imaps" "imap")))))
+    (let* ((coding-system-for-read 'binary)
+	   (coding-system-for-write 'binary)
+	   (credentials
+	    (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")))
+	      (nnimap-credentials nnimap-address "143" "imap"))
+	     ((eq nnimap-stream 'stream)
+	      (nnimap-open-shell-stream
+	       "*nnimap*" (current-buffer) nnimap-address
+	       (or nnimap-server-port "imap"))
+	      (nnimap-credentials nnimap-address "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")))
+	      (nnimap-credentials nnimap-address "143" "993" "imap" "imaps")))))
       (setf (nnimap-process nnimap-object)
 	    (get-buffer-process (current-buffer)))
       (unless credentials
-	(delete-process (nnimap-process nnimap-object))
-	(error "Can't find user name/password for %s" nnimap-address))
+	(delete-process (nnimap-process nnimap-object)))
       (when (and (nnimap-process nnimap-object)
 		 (memq (process-status (nnimap-process nnimap-object))
 		       '(open run)))
 	(gnus-set-process-query-on-exit-flag (nnimap-process nnimap-object) nil)
 	(let ((result (nnimap-command "LOGIN %S %S"
 				      (car credentials) (cadr credentials))))
-	  (unless (car result)
-	    (delete-process (nnimap-process nnimap-object))
-	    (error "Unable to login to the server: %s"
-		   (mapconcat #'identity (cadr result) " ")))
-	  (setf (nnimap-capabilities nnimap-object)
-		(or (nnimap-find-parameter "CAPABILITY" (cdr result))
-		    (nnimap-find-parameter
-		     "CAPABILITY" (cdr (nnimap-command "CAPABILITY")))))
-	  (when (member "QRESYNC" (nnimap-capabilities nnimap-object))
-	    (nnimap-command "ENABLE QRESYNC"))
-	  t)))))
+	  (if (not (car result))
+	      (progn
+		(delete-process (nnimap-process nnimap-object))
+		nil)
+	    (setf (nnimap-capabilities nnimap-object)
+		  (mapcar
+		   #'upcase
+		   (or (nnimap-find-parameter "CAPABILITY" (cdr result))
+		       (nnimap-find-parameter
+			"CAPABILITY" (cdr (nnimap-command "CAPABILITY"))))))
+	    (when (member "QRESYNC" (nnimap-capabilities nnimap-object))
+	      (nnimap-command "ENABLE QRESYNC"))
+	    t))))))
 
 (defun nnimap-find-parameter (parameter elems)
   (let (result)
@@ -219,22 +274,22 @@ not done by default on servers that doesn't support that command.")
 	(setq result (cdr (cadr elem))))))
     result))
 
-(defun nnimap-close-server (&optional server)
+(deffoo nnimap-close-server (&optional server)
   t)
 
-(defun nnimap-request-close ()
+(deffoo nnimap-request-close ()
   t)
 
-(defun nnimap-server-opened (&optional server)
+(deffoo nnimap-server-opened (&optional server)
   (and (nnoo-current-server-p 'nnimap server)
        nntp-server-buffer
        (gnus-buffer-live-p nntp-server-buffer)
        (nnimap-find-connection nntp-server-buffer)))
 
-(defun nnimap-status-message (&optional server)
+(deffoo nnimap-status-message (&optional server)
   nnimap-status-string)
 
-(defun nnimap-request-article (article &optional group server to-buffer)
+(deffoo nnimap-request-article (article &optional group server to-buffer)
   (with-current-buffer nntp-server-buffer
     (let ((result (nnimap-possibly-change-group group server)))
       (when (stringp article)
@@ -242,14 +297,14 @@ not done by default on servers that doesn't support that command.")
       (when (and result
 		 article)
 	(erase-buffer)
-	(nnimap-with-process-buffer
-	 (erase-buffer)
-	 (setq result
-	       (nnimap-command
-		(if (member "IMAP4rev1" (nnimap-capabilities nnimap-object))
-		    "UID FETCH %d BODY.PEEK[]"
-		  "UID FETCH %d RFC822.PEEK")
-		article)))
+	(with-current-buffer (nnimap-buffer)
+	  (erase-buffer)
+	  (setq result
+		(nnimap-command
+		 (if (member "IMAP4REV1" (nnimap-capabilities nnimap-object))
+		     "UID FETCH %d BODY.PEEK[]"
+		   "UID FETCH %d RFC822.PEEK")
+		 article)))
 	(let ((buffer (nnimap-find-process-buffer (current-buffer))))
 	  (when (car result)
 	    (with-current-buffer to-buffer
@@ -263,20 +318,39 @@ not done by default on servers that doesn't support that command.")
 		(nnheader-ms-strip-cr))
 	      t)))))))
 
-(defun nnimap-request-group (group &optional server dont-check)
+(deffoo nnimap-request-group (group &optional server dont-check info)
   (with-current-buffer nntp-server-buffer
     (let ((result (nnimap-possibly-change-group group server))
-	  articles)
+	  articles active marks)
       (when result
-	(setq articles (nnimap-get-flags "1:*"))
-	(erase-buffer)
-	(insert
-	 (format
-	  "211 %d %d %d %S\n"
-	  (length articles)
-	  (or (caar articles) 0)
-	  (or (caar (last articles)) 0)
-	  group))
+	(if (and dont-check
+		 (setq active (nth 2 (assoc group nnimap-current-infos))))
+	    (insert (format "211 %d %d %d %S\n"
+			    (- (cdr active) (car active))
+			    (car active)
+			    (cdr active)
+			    group))
+	  (with-current-buffer (nnimap-buffer)
+	    (erase-buffer)
+	    (let ((group-sequence
+		   (nnimap-send-command "SELECT %S" (utf7-encode group)))
+		  (flag-sequence
+		   (nnimap-send-command "UID FETCH 1:* FLAGS")))
+	      (nnimap-wait-for-response flag-sequence)
+	      (setq marks
+		    (nnimap-flags-to-marks
+		     (nnimap-parse-flags
+		      (list (list group-sequence flag-sequence 1 group)))))
+	      (when info
+		(nnimap-update-infos marks (list info)))))
+	  (erase-buffer)
+	  (let ((high (nth 3 (car marks)))
+		(low (nth 4 (car marks))))
+	    (insert
+	     (format
+	      "211 %d %d %d %S\n"
+	      (1+ (- high low))
+	      low high group))))
 	t))))
 
 (defun nnimap-get-flags (spec)
@@ -294,7 +368,7 @@ not done by default on servers that doesn't support that command.")
 	      articles)))
     (nreverse articles)))
 
-(defun nnimap-close-group (group &optional server)
+(deffoo nnimap-close-group (group &optional server)
   t)
 
 (deffoo nnimap-request-move-article (article group server accept-form
@@ -366,10 +440,10 @@ not done by default on servers that doesn't support that command.")
 	(push flag flags)))
     flags))
 
-(defun nnimap-request-set-mark (group actions &optional server)
+(deffoo nnimap-request-set-mark (group actions &optional server)
   (when (nnimap-possibly-change-group group server)
     (let (sequence)
-      (with-current-buffer (nnimap-find-process-buffer nntp-server-buffer)
+      (with-current-buffer (nnimap-buffer)
 	;; Just send all the STORE commands without waiting for
 	;; response.  If they're successful, they're successful.
 	(dolist (action actions)
@@ -393,17 +467,16 @@ not done by default on servers that doesn't support that command.")
     (let ((message (buffer-string))
 	  (message-id (message-field-value "message-id"))
 	  sequence)
-      (with-current-buffer nntp-server-buffer
-	(nnimap-with-process-buffer
-	 (setq sequence (nnimap-send-command
-			 "APPEND %S {%d}" (utf7-encode group t)
-			 (length message)))
-	 (process-send-string (get-buffer-process (current-buffer)) message)
-	 (process-send-string (get-buffer-process (current-buffer)) "\r\n")
-	 (let ((result (nnimap-get-response sequence)))
-	   (when result
-	     (cons group
-		   (nnimap-find-article-by-message-id group message-id)))))))))
+      (with-current-buffer (nnimap-buffer)
+	(setq sequence (nnimap-send-command
+			"APPEND %S {%d}" (utf7-encode group t)
+			(length message)))
+	(process-send-string (get-buffer-process (current-buffer)) message)
+	(process-send-string (get-buffer-process (current-buffer)) "\r\n")
+	(let ((result (nnimap-get-response sequence)))
+	  (when result
+	    (cons group
+		  (nnimap-find-article-by-message-id group message-id))))))))
 
 (defun nnimap-add-cr ()
   (goto-char (point-min))
@@ -416,27 +489,28 @@ not done by default on servers that doesn't support that command.")
     (when (car result)
       (dolist (line (cdr result))
 	(when (and (equal (car line) "LIST")
-		   (not (string-match "noselect" (caadr line))))
+		   (not (and (caadr line)
+			     (string-match "noselect" (caadr line)))))
 	  (push (car (last line)) groups)))
       (nreverse groups))))
 
-(defun nnimap-request-list (&optional server)
+(deffoo nnimap-request-list (&optional server)
   (nnimap-possibly-change-group nil server)
   (with-current-buffer nntp-server-buffer
     (erase-buffer)
     (let ((groups
-	   (nnimap-with-process-buffer
-	    (nnimap-get-groups)))
+	   (with-current-buffer (nnimap-buffer)
+	     (nnimap-get-groups)))
 	  sequences responses)
       (when groups
-	(nnimap-with-process-buffer
-	 (dolist (group groups)
-	   (push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t))
-		       group)
-		 sequences))
-	 (nnimap-wait-for-response (caar sequences))
-	 (setq responses
-	       (nnimap-get-responses (mapcar #'car sequences))))
+	(with-current-buffer (nnimap-buffer)
+	  (dolist (group groups)
+	    (push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t))
+			group)
+		  sequences))
+	  (nnimap-wait-for-response (caar sequences))
+	  (setq responses
+		(nnimap-get-responses (mapcar #'car sequences))))
 	(dolist (response responses)
 	  (let* ((sequence (car response))
 		 (response (cadr response))
@@ -450,16 +524,20 @@ not done by default on servers that doesn't support that command.")
 		    (setq exists (string-to-number (car elem)))))
 		(when uidnext
 		  (setq highest (1- (string-to-number (car uidnext)))))
-		(if (zerop exists)
-		    ;; Empty group.
-		    (insert (format "%S %d %d y\n"
-				    (utf7-decode group t) highest (1+ highest)))
+		(cond
+		 ((null highest)
+		  (insert (format "%S 0 1 y\n" (utf7-decode group t))))
+		 ((zerop exists)
+		  ;; Empty group.
+		  (insert (format "%S %d %d y\n"
+				  (utf7-decode group t) highest (1+ highest))))
+		 (t
 		  ;; Return the widest possible range.
 		  (insert (format "%S %d 1 y\n" (utf7-decode group t)
-				  (or highest exists))))))))
+				  (or highest exists)))))))))
 	t))))
 
-(defun nnimap-retrieve-group-data-early (server infos)
+(deffoo nnimap-retrieve-group-data-early (server infos)
   (when (nnimap-possibly-change-group nil server)
     (with-current-buffer (nnimap-buffer)
       ;; QRESYNC handling isn't implemented.
@@ -499,8 +577,9 @@ not done by default on servers that doesn't support that command.")
 		    sequences))))
 	sequences))))
 
-(defun nnimap-finish-retrieve-group-infos (server infos sequences)
-  (when (nnimap-possibly-change-group nil server)
+(deffoo nnimap-finish-retrieve-group-infos (server infos sequences)
+  (when (and sequences
+	     (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))
@@ -524,7 +603,8 @@ not done by default on servers that doesn't support that command.")
 	    (completep (and start-article
 			    (= start-article 1))))
 	;; First set the active ranges based on high/low.
-	(if completep
+	(if (or completep
+		(not (gnus-active group)))
 	    (gnus-set-active group
 			     (if high
 				 (cons low high)
@@ -570,7 +650,15 @@ not done by default on servers that doesn't support that command.")
 		(setq new-marks (gnus-range-nconcat old-marks new-marks)))
 	      (when new-marks
 		(push (cons (car type) new-marks) marks)))
-	    (gnus-info-set-marks info marks)))))))
+	    (gnus-info-set-marks info marks)
+	    (nnimap-store-info info (gnus-active group))))))))
+
+(defun nnimap-store-info (info active)
+  (let* ((group (gnus-group-real-name (gnus-info-group info)))
+	 (entry (assoc group nnimap-current-infos)))
+    (if entry
+	(setcdr entry (list info active))
+      (push (list group info active) nnimap-current-infos))))
 
 (defun nnimap-flags-to-marks (groups)
   (let (data group totalp uidnext articles start-article mark)
@@ -624,23 +712,29 @@ not done by default on servers that doesn't support that command.")
 (defun nnimap-find-process-buffer (buffer)
   (cadr (assoc buffer nnimap-connection-alist)))
 
-(defun nnimap-request-post (&optional server)
+(deffoo nnimap-request-post (&optional server)
   (setq nnimap-status-string "Read-only server")
   nil)
 
 (defun nnimap-possibly-change-group (group server)
-  (when (and server
-	     (not (nnimap-server-opened server)))
-    (nnimap-open-server server))
-  (if (not group)
-      t
-    (with-current-buffer (nnimap-buffer)
-      (if (equal group (nnimap-group nnimap-object))
-	  t
-	(let ((result (nnimap-command "SELECT %S" (utf7-encode group t))))
-	  (when (car result)
-	    (setf (nnimap-group nnimap-object) group)
-	    result))))))
+  (let ((open-result t))
+    (when (and server
+	       (not (nnimap-server-opened server)))
+      (setq open-result (nnimap-open-server server)))
+    (cond
+     ((not open-result)
+      nil)
+     ((not group)
+      t)
+     (t
+      (with-current-buffer (nnimap-buffer)
+	(if (equal group (nnimap-group nnimap-object))
+	    t
+	  (let ((result (nnimap-command "SELECT %S" (utf7-encode group t))))
+	    (when (car result)
+	      (setf (nnimap-group nnimap-object) group
+		    (nnimap-select-result nnimap-object) result)
+	      result))))))))
 
 (defun nnimap-find-connection (buffer)
   "Find the connection delivering to BUFFER."
@@ -768,7 +862,7 @@ not done by default on servers that doesn't support that command.")
     (nnimap-article-ranges articles)
     (format "(UID %s%s)"
 	    (format
-	     (if (member "IMAP4rev1"
+	     (if (member "IMAP4REV1"
 			 (nnimap-capabilities nnimap-object))
 		 "BODY.PEEK[HEADER] BODY.PEEK"
 	       "RFC822.PEEK"))