X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnnimap.el;h=12f9ef8c861d66c7da59b008b18f4f6953fd7014;hb=c7e1791dc423f18fde3a940c1d2f93f6b11899b2;hp=bc576f481ce8f30d555c93bb079db45a21aec6c9;hpb=03440feabbb3101aa039ec10ff2a41d4a38c3c20;p=gnus

diff --git a/lisp/nnimap.el b/lisp/nnimap.el
index bc576f481..12f9ef8c8 100644
--- a/lisp/nnimap.el
+++ b/lisp/nnimap.el
@@ -1,5 +1,5 @@
 ;;; nnimap.el --- imap backend for Gnus
-;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003
+;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005
 ;;        Free Software Foundation, Inc.
 
 ;; Author: Simon Josefsson <jas@pdc.kth.se>
@@ -70,6 +70,8 @@
 (require 'gnus-start)
 (require 'gnus-int)
 
+(eval-when-compile (require 'cl))
+
 (nnoo-declare nnimap)
 
 (defconst nnimap-version "nnimap 1.0")
@@ -192,7 +194,7 @@ RFC2060 section 6.4.4."
   :type 'string)
 
 (defcustom nnimap-split-fancy nil
-  "Like the variable `nnmail-split-fancy', which see."
+  "Like the variable `nnmail-split-fancy'."
   :group 'nnimap
   :type 'sexp)
 
@@ -209,6 +211,7 @@ variable is the symbol `default' the default behaviour is
 used (which currently is nil, unless you use a statistical
 spam.el test); if this variable is another non-nil value bodies
 will be downloaded."
+  :version "22.1"
   :group 'nnimap
   :type '(choice (const :tag "Let system decide" deault)
 		 boolean))
@@ -217,9 +220,10 @@ will be downloaded."
 
 (defcustom nnimap-close-asynchronous t
   "Close mailboxes asynchronously in `nnimap-close-group'.
-This means that errors cought by nnimap when closing the mailbox will
+This means that errors caught by nnimap when closing the mailbox will
 not prevent Gnus from updating the group status, which may be harmful.
 However, it increases speed."
+  :version "22.1"
   :type 'boolean
   :group 'nnimap)
 
@@ -228,6 +232,7 @@ However, it increases speed."
 This increases the speed of closing mailboxes (quiting group) but may
 decrease the speed of selecting another mailbox later.  Re-selecting
 the same mailbox will be faster though."
+  :version "22.1"
   :type 'boolean
   :group 'nnimap)
 
@@ -240,6 +245,7 @@ more carefully for new mail.
 
 In summary, the default is O((1-p)*k+p*n) and changing it to nil makes
 it O(n).  If p is small, then the default is probably faster."
+  :version "22.1"
   :type 'boolean
   :group 'nnimap)
 
@@ -389,19 +395,62 @@ just like \"ticked\" articles, in other IMAP clients.")
 					  (string :format "Login: %v"))
 				    (cons :format "%v"
 					  (const :format "" "password")
-					  (string :format "Password: %v")))))))
+					  (string :format "Password: %v"))))))
+  :group 'nnimap)
 
 (defcustom nnimap-prune-cache t
   "If non-nil, nnimap check whether articles still exist on server before using data stored in NOV cache."
-  :type 'boolean)
+  :type 'boolean
+  :group 'nnimap)
 
 (defvar nnimap-request-list-method 'imap-mailbox-list
   "Method to use to request a list of all folders from the server.
 If this is 'imap-mailbox-lsub, then use a server-side subscription list to
 restrict visible folders.")
 
+(defcustom nnimap-id nil
+  "Plist with client identity to send to server upon login.
+Nil means no information is sent, symbol `no' to disable ID query
+alltogheter, or plist with identifier-value pairs to send to
+server.  RFC 2971 describes the list as follows:
+
+   Any string may be sent as a field, but the following are defined to
+   describe certain values that might be sent.  Implementations are free
+   to send none, any, or all of these.  Strings are not case-sensitive.
+   Field strings MUST NOT be longer than 30 octets.  Value strings MUST
+   NOT be longer than 1024 octets.  Implementations MUST NOT send more
+   than 30 field-value pairs.
+
+     name            Name of the program
+     version         Version number of the program
+     os              Name of the operating system
+     os-version      Version of the operating system
+     vendor          Vendor of the client/server
+     support-url     URL to contact for support
+     address         Postal address of contact/vendor
+     date            Date program was released, specified as a date-time
+                       in IMAP4rev1
+     command         Command used to start the program
+     arguments       Arguments supplied on the command line, if any
+                       if any
+     environment     Description of environment, i.e., UNIX environment
+                       variables or Windows registry settings
+
+   Implementations MUST NOT send the same field name more than once.
+
+An example plist would be '(\"name\" \"Gnus\" \"version\" gnus-version-number
+\"os\" system-configuration \"vendor\" \"GNU\")."
+  :group 'nnimap
+  :type '(choice (const :tag "No information" nil)
+		 (const :tag "Disable ID query" no)
+		 (plist :key-type string :value-type string)))
+
 (defcustom nnimap-debug nil
-  "If non-nil, random debug spews are placed in *nnimap-debug* buffer."
+  "If non-nil, random debug spews are placed in *nnimap-debug* buffer.
+Note that username, passwords and other privacy sensitive
+information (such as e-mail) may be stored in the *nnimap-debug*
+buffer.  It is not written to disk, however.  Do not enable this
+variable unless you are comfortable with that."
   :group 'nnimap
   :type 'boolean)
 
@@ -430,6 +479,14 @@ restrict visible folders.")
   "Return buffer for SERVER, if nil use current server."
   (cadr (assoc (or server nnimap-current-server) nnimap-server-buffer-alist)))
 
+(defun nnimap-remove-server-from-buffer-alist (server list)
+  "Remove SERVER from LIST."
+  (let (l)
+    (dolist (e list)
+      (unless (equal server (car-safe e))
+	(push e l)))
+    l))
+
 (defun nnimap-possibly-change-server (server)
   "Return buffer for SERVER, changing the current server as a side-effect.
 If SERVER is nil, uses the current server."
@@ -548,7 +605,7 @@ If EXAMINE is non-nil the group is selected read-only."
        (with-temp-buffer
 	 (buffer-disable-undo)
 	 (insert headers)
-	 (let ((head (nnheader-parse-naked-head)))
+	 (let ((head (nnheader-parse-naked-head uid)))
 	   (mail-header-set-number head uid)
 	   (mail-header-set-chars head chars)
 	   (mail-header-set-lines head lines)
@@ -653,6 +710,8 @@ If EXAMINE is non-nil the group is selected read-only."
 			    (if (imap-capability 'IMAP4rev1)
 				(format "BODY.PEEK[HEADER.FIELDS %s])" headers)
 			      (format "RFC822.HEADER.LINES %s)" headers)))))
+      (with-current-buffer nntp-server-buffer
+	(sort-numeric-fields 1 (point-min) (point-max)))
       (and (numberp nnmail-large-newsgroup)
 	   (> nnimap-length nnmail-large-newsgroup)
 	   (nnheader-message 6 "nnimap: Retrieving headers...done")))))
@@ -714,19 +773,37 @@ If EXAMINE is non-nil the group is selected read-only."
 		(imap-capability 'IMAP4rev1 nnimap-server-buffer))
       (imap-close nnimap-server-buffer)
       (nnheader-report 'nnimap "Server %s is not IMAP4 compliant" server))
-    (let* ((list (gnus-parse-netrc nnimap-authinfo-file))
-	   (port (if nnimap-server-port
-		     (int-to-string nnimap-server-port)
-		   "imap"))
-	   (alist (gnus-netrc-machine list (or nnimap-server-address
-					       nnimap-address server)
-				      port "imap"))
-	   (user (gnus-netrc-get alist "login"))
-	   (passwd (gnus-netrc-get alist "password")))
+    (let* ((list (progn (gnus-message 7 "Parsing authinfo file `%s'."
+				      nnimap-authinfo-file)
+			(netrc-parse nnimap-authinfo-file)))
+ 	   (port (if nnimap-server-port
+ 		     (int-to-string nnimap-server-port)
+ 		   "imap"))
+	   (user (netrc-machine-user-or-password 
+		  "login"
+		  list
+		  (list server
+			(or nnimap-server-address
+			    nnimap-address))
+		  (list port)
+		  (list "imap" "imaps")))
+	   (passwd (netrc-machine-user-or-password 
+		    "password"
+		    list
+		    (list server
+			  (or nnimap-server-address
+			      nnimap-address))
+		    (list port)
+		    (list "imap" "imaps"))))
       (if (imap-authenticate user passwd nnimap-server-buffer)
-	  (prog1
+	  (prog2
+	      (setq nnimap-server-buffer-alist
+		    (nnimap-remove-server-from-buffer-alist 
+		     server
+		     nnimap-server-buffer-alist))
 	      (push (list server nnimap-server-buffer)
 		    nnimap-server-buffer-alist)
+	    (imap-id nnimap-id nnimap-server-buffer)
 	    (nnimap-possibly-change-server server))
 	(imap-close nnimap-server-buffer)
 	(kill-buffer nnimap-server-buffer)
@@ -753,7 +830,7 @@ If EXAMINE is non-nil the group is selected read-only."
     (or (and nnimap-server-buffer
 	     (imap-opened nnimap-server-buffer)
 	     (if (with-current-buffer nnimap-server-buffer
-		   (memq imap-state '(auth select examine)))
+		   (memq imap-state '(auth selected examine)))
 		 t
 	       (imap-close nnimap-server-buffer)
 	       (nnimap-open-connection server)))
@@ -780,7 +857,9 @@ Return nil if the server couldn't be closed for some reason."
       (setq nnimap-server-buffer nil
 	    nnimap-current-server nil
 	    nnimap-server-buffer-alist
-	    (delq server nnimap-server-buffer-alist)))
+	    (nnimap-remove-server-from-buffer-alist 
+	     server
+	     nnimap-server-buffer-alist)))
     (nnoo-close-server 'nnimap server)))
 
 (deffoo nnimap-request-close ()
@@ -788,8 +867,8 @@ Return nil if the server couldn't be closed for some reason."
 All buffers that have been created by that
 backend should be killed.  (Not the nntp-server-buffer, though.) This
 function is generally only called when Gnus is shutting down."
-  (mapcar (lambda (server) (nnimap-close-server (car server)))
-	  nnimap-server-buffer-alist)
+  (mapc (lambda (server) (nnimap-close-server (car server)))
+	nnimap-server-buffer-alist)
   (setq nnimap-server-buffer-alist nil))
 
 (deffoo nnimap-status-message (&optional server)
@@ -798,6 +877,11 @@ function is generally only called when Gnus is shutting down."
     (nnoo-status-message 'nnimap server)))
 
 (defun nnimap-demule (string)
+  ;; BEWARE: we used to use string-as-multibyte here which is braindead
+  ;; because it will turn accidental emacs-mule-valid byte sequences
+  ;; into multibyte chars.  --Stef
+  ;; Reverted, braindead got 7.5 out of 10 on imdb, so it can't be
+  ;; that bad. --Simon
   (funcall (if (and (fboundp 'string-as-multibyte)
 		    (subrp (symbol-function 'string-as-multibyte)))
 	       'string-as-multibyte
@@ -806,7 +890,7 @@ function is generally only called when Gnus is shutting down."
 
 (defun nnimap-make-callback (article gnus-callback buffer)
   "Return a callback function."
-  `(lambda () 
+  `(lambda ()
      (nnimap-callback ,article ,gnus-callback ,buffer)))
 
 (defun nnimap-callback (article gnus-callback buffer)
@@ -856,8 +940,8 @@ function is generally only called when Gnus is shutting down."
 				   (imap-error-text nnimap-server-buffer))
 		(cons group article)))
 	  (add-hook 'imap-fetch-data-hook
-		    (nnimap-make-callback article 
-					  nnheader-callback-function 
+		    (nnimap-make-callback article
+					  nnheader-callback-function
 					  nntp-server-buffer))
 	  (imap-fetch-asynch article part nil nnimap-server-buffer)
 	  (cons group article))))))
@@ -910,7 +994,7 @@ function is generally only called when Gnus is shutting down."
   "Update the unseen count in `nnimap-mailbox-info'."
   (gnus-sethash
    (gnus-group-prefixed-name group server)
-   (let ((old (gnus-gethash-safe (gnus-group-prefixed-name group server) 
+   (let ((old (gnus-gethash-safe (gnus-group-prefixed-name group server)
 				 nnimap-mailbox-info)))
      (list (nth 0 old) (nth 1 old)
 	   (imap-mailbox-status group 'unseen nnimap-server-buffer)
@@ -1023,7 +1107,7 @@ function is generally only called when Gnus is shutting down."
 			     'asyncgroups
 			   'slowgroups)
 			 (list group (imap-mailbox-status-asynch
-				      group '(uidvalidity uidnext unseen) 
+				      group '(uidvalidity uidnext unseen)
 				      nnimap-server-buffer))))
 	  (dolist (asyncgroup asyncgroups)
 	    (let ((group (nth 0 asyncgroup))
@@ -1034,7 +1118,7 @@ function is generally only called when Gnus is shutting down."
 			      (nth 0 (gnus-gethash (gnus-group-prefixed-name
 						    group server)
 						   nnimap-mailbox-info))
-			      (imap-mailbox-get 'uidvalidity group 
+			      (imap-mailbox-get 'uidvalidity group
 						nnimap-server-buffer)))
 			(not (string=
 			      (nth 1 (gnus-gethash (gnus-group-prefixed-name
@@ -1176,11 +1260,11 @@ function is generally only called when Gnus is shutting down."
 	      (if (memq 'dormant cmdmarks)
 		  (setq cmdmarks (cons 'tick cmdmarks))))
 	    ;; remove stuff we are forbidden to store
-	    (mapcar (lambda (mark)
-		      (if (imap-message-flag-permanent-p
-			   (nnimap-mark-to-flag mark))
-			  (setq marks (cons mark marks))))
-		    cmdmarks)
+	    (mapc (lambda (mark)
+		    (if (imap-message-flag-permanent-p
+			 (nnimap-mark-to-flag mark))
+			(setq marks (cons mark marks))))
+		  cmdmarks)
 	    (when (and range marks)
 	      (cond ((eq what 'del)
 		     (imap-message-flags-del
@@ -1267,9 +1351,11 @@ function is generally only called when Gnus is shutting down."
 	  (when (setq rule (nnimap-split-find-rule server inbox))
 	    ;; iterate over articles
 	    (dolist (article (imap-search nnimap-split-predicate))
-	      (when (if nnimap-split-download-body
+	      (when (if (if (eq nnimap-split-download-body 'default)
+			    nnimap-split-download-body-default
+			  nnimap-split-download-body)
 			(and (nnimap-request-article article)
-			     (mail-narrow-to-head))
+			     (with-current-buffer nntp-server-buffer (mail-narrow-to-head)))
 		      (nnimap-request-head article))
 		;; copy article to right group(s)
 		(setq removeorig nil)
@@ -1285,16 +1371,20 @@ function is generally only called when Gnus is shutting down."
 			 (setq removeorig t)
 			 (when nnmail-cache-accepted-message-ids
 			   (with-current-buffer nntp-server-buffer
-                             (let (msgid)
-                               (and (setq msgid
+			     (let (msgid)
+			       (and (setq msgid
 					  (nnmail-fetch-field "message-id"))
-                                    (nnmail-cache-insert msgid to-group)))))
+				    (nnmail-cache-insert msgid
+							 to-group
+							 (nnmail-fetch-field "subject"))))))
 			 ;; Add the group-art list to the history list.
 			 (push (list (cons to-group 0)) nnmail-split-history))
 			(t
 			 (message "IMAP split failed to move %s:%s:%d to %s"
 				  server inbox article to-group))))
-		(if nnimap-split-download-body
+		(if (if (eq nnimap-split-download-body 'default)
+			nnimap-split-download-body-default
+		      nnimap-split-download-body)
 		    (widen))
 		;; remove article if it was successfully copied somewhere
 		(and removeorig
@@ -1320,7 +1410,7 @@ function is generally only called when Gnus is shutting down."
       (nnimap-before-find-minmax-bugworkaround)
       (dolist (pattern (nnimap-pattern-to-list-arguments
 			nnimap-list-pattern))
-	(dolist (mbx (imap-mailbox-lsub "*" (car pattern) nil
+	(dolist (mbx (imap-mailbox-lsub (cdr pattern) (car pattern) nil
 					nnimap-server-buffer))
 	  (or (catch 'found
 		(dolist (mailbox (imap-mailbox-get 'list-flags mbx
@@ -1352,8 +1442,10 @@ function is generally only called when Gnus is shutting down."
 	(list (- ms 1) (+ (expt 2 16) ls))
       (list ms ls))))
 
+(eval-when-compile (require 'parse-time))
 (defun nnimap-date-days-ago (daysago)
   "Return date, in format \"3-Aug-1998\", for DAYSAGO days ago."
+  (require 'parse-time)
   (let* ((time (nnimap-time-substract (current-time) (days-to-time daysago)))
 	 (date (format-time-string
 		(format "%%d-%s-%%Y"
@@ -1392,12 +1484,12 @@ function is generally only called when Gnus is shutting down."
 			nnmail-expiry-wait)))
 	  (cond ((or force (eq days 'immediate))
 		 (let ((oldarts (imap-search
-				 (concat "UID " 
+				 (concat "UID "
 					 (imap-range-to-message-set artseq)))))
 		   (when oldarts
 		     (nnimap-expiry-target oldarts group server)
 		     (when (imap-message-flags-add
-			    (imap-range-to-message-set 
+			    (imap-range-to-message-set
 			     (gnus-compress-sequence oldarts)) "\\Deleted")
 		       (setq articles (gnus-set-difference
 				       articles oldarts))))))
@@ -1411,15 +1503,15 @@ function is generally only called when Gnus is shutting down."
 		   (when oldarts
 		     (nnimap-expiry-target oldarts group server)
 		     (when (imap-message-flags-add
-			    (imap-range-to-message-set 
+			    (imap-range-to-message-set
 			     (gnus-compress-sequence oldarts)) "\\Deleted")
-		       (setq articles (gnus-set-difference 
+		       (setq articles (gnus-set-difference
 				       articles oldarts)))))))))))
   ;; return articles not deleted
   articles)
 
-(deffoo nnimap-request-move-article (article group server
-					     accept-form &optional last)
+(deffoo nnimap-request-move-article (article group server accept-form 
+					     &optional last move-is-internal)
   (when (nnimap-possibly-change-server server)
     (save-excursion
       (let ((buf (get-buffer-create " *nnimap move*"))
@@ -1427,7 +1519,13 @@ function is generally only called when Gnus is shutting down."
 	    (nnimap-current-move-group group)
 	    (nnimap-current-move-server nnimap-current-server)
 	    result)
-	(and (nnimap-request-article article group server)
+	(gnus-message 10 "nnimap-request-move-article: this is an %s move"
+		      (if move-is-internal
+			  "internal"
+			"external"))
+	;; request the article only when the move is NOT internal
+	(and (or move-is-internal
+		 (nnimap-request-article article group server))
 	     (save-excursion
 	       (set-buffer buf)
 	       (buffer-disable-undo (current-buffer))
@@ -1463,7 +1561,8 @@ function is generally only called when Gnus is shutting down."
 		      (replace-match "\r\n"))
 		    (when nnmail-cache-accepted-message-ids
 		      (nnmail-cache-insert (nnmail-fetch-field "message-id")
-					   group)))
+					   group
+					   (nnmail-fetch-field "subject"))))
 		  (when (and last nnmail-cache-accepted-message-ids)
 		    (nnmail-cache-close))
 		  ;; this 'or' is for Cyrus server bug
@@ -1502,21 +1601,21 @@ function is generally only called when Gnus is shutting down."
       (error "Your server does not support ACL editing"))
     (with-current-buffer nnimap-server-buffer
       ;; delete all removed identifiers
-      (mapcar (lambda (old-acl)
-		(unless (assoc (car old-acl) new-acls)
-		  (or (imap-mailbox-acl-delete (car old-acl) mailbox)
-		      (error "Can't delete ACL for %s" (car old-acl)))))
-	      old-acls)
+      (mapc (lambda (old-acl)
+	      (unless (assoc (car old-acl) new-acls)
+		(or (imap-mailbox-acl-delete (car old-acl) mailbox)
+		    (error "Can't delete ACL for %s" (car old-acl)))))
+	    old-acls)
       ;; set all changed acl's
-      (mapcar (lambda (new-acl)
-		(let ((new-rights (cdr new-acl))
-		      (old-rights (cdr (assoc (car new-acl) old-acls))))
-		  (unless (and old-rights new-rights
-			       (string= old-rights new-rights))
-		    (or (imap-mailbox-acl-set (car new-acl) new-rights mailbox)
-			(error "Can't set ACL for %s to %s" (car new-acl)
-			       new-rights)))))
-	      new-acls)
+      (mapc (lambda (new-acl)
+	      (let ((new-rights (cdr new-acl))
+		    (old-rights (cdr (assoc (car new-acl) old-acls))))
+		(unless (and old-rights new-rights
+			     (string= old-rights new-rights))
+		  (or (imap-mailbox-acl-set (car new-acl) new-rights mailbox)
+		      (error "Can't set ACL for %s to %s" (car new-acl)
+			     new-rights)))))
+	    new-acls)
       t)))
 
 
@@ -1656,4 +1755,5 @@ be used in a STORE FLAGS command."
 
 (provide 'nnimap)
 
+;; arch-tag: 2b001f20-3ff9-4094-a0ad-46807c1ba70b
 ;;; nnimap.el ends here