X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnnimap.el;h=d36f225d44d51c80f4e6f573e78ca167d693cfa0;hb=9a60f093f45ad3169be0d0cc4a2bf75ba599aca8;hp=cfd3be586b8d77e5c70b215d27ce08aef492a612;hpb=014087b33ef4ac3b1ede0b6b2522e739e20d6e0c;p=gnus diff --git a/lisp/nnimap.el b/lisp/nnimap.el index cfd3be586..d36f225d4 100644 --- a/lisp/nnimap.el +++ b/lisp/nnimap.el @@ -1,5 +1,6 @@ ;;; nnimap.el --- imap backend for Gnus -;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 +;; Free Software Foundation, Inc. ;; Author: Simon Josefsson ;; Jim Radford @@ -42,7 +43,7 @@ ;; o Split up big fetches (1,* header especially) in smaller chunks ;; o What do I do with gnus-newsgroup-*? ;; o Tell Gnus about new groups (how can we tell?) -;; o Respooling (fix Gnus?) (unnecessery?) +;; o Respooling (fix Gnus?) (unnecessary?) ;; o Add support for the following: (if applicable) ;; request-list-newsgroups, request-regenerate ;; list-active-group, @@ -69,6 +70,8 @@ (require 'gnus-start) (require 'gnus-int) +(eval-when-compile (require 'cl)) + (nnoo-declare nnimap) (defconst nnimap-version "nnimap 1.0") @@ -82,7 +85,7 @@ (defvoo nnimap-server-port nil "Port number on physical IMAP server. -If nil, defaults to 993 for SSL connections and 143 otherwise.") +If nil, defaults to 993 for TLS/SSL connections and 143 otherwise.") ;; Splitting variables @@ -115,7 +118,7 @@ loaded function will not match. Use with care." (functionp value)) (defcustom nnimap-split-rule nil - "Mail will be split according to theese rules. + "Mail will be split according to these rules. Mail is read from mailbox(es) specified in `nnimap-split-inbox'. @@ -127,10 +130,10 @@ this: \(setq nnimap-split-rule '((\"INBOX.gnus-imap\" \"From:.*gnus-imap\") (\"INBOX.junk\" \"Subject:.*buy\"))) -As you can see, `nnimap-split-rule' is a list of lists, where the first -element in each \"rule\" is the name of the IMAP mailbox, and the -second is a regexp that nnimap will try to match on the header to find -a fit. +As you can see, `nnimap-split-rule' is a list of lists, where the +first element in each \"rule\" is the name of the IMAP mailbox (or the +symbol `junk' if you want to remove the mail), and the second is a +regexp that nnimap will try to match on the header to find a fit. The second element can also be a function. In that case, it will be called narrowed to the headers with the first element of the rule as @@ -191,10 +194,27 @@ 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) +(defvar nnimap-split-download-body-default nil + "Internal variable with default value for `nnimap-split-download-body'.") + +(defcustom nnimap-split-download-body 'default + "Whether to download entire articles during splitting. +This is generally not required, and will slow things down considerably. +You may need it if you want to use an advanced splitting function that +analyses the body before splitting the article. +If this variable is nil, bodies will not be downloaded; if this +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." + :group 'nnimap + :type '(choice (const :tag "Let system decide" deault) + boolean)) + ;; Performance / bug workaround variables (defcustom nnimap-close-asynchronous t @@ -242,14 +262,16 @@ handle. Change this if -1) you want to connect with SSL. The SSL integration with IMAP is - brain-dead so you'll have to tell it specifically. +1) you want to connect with TLS/SSL. The TLS/SSL integration + with IMAP is suboptimal so you'll have to tell it + specifically. 2) your server is more capable than your environment -- i.e. your server accept Kerberos login's but you haven't installed the `imtest' program or your machine isn't configured for Kerberos. -Possible choices: kerberos4, ssl, network") +Possible choices: gssapi, kerberos4, starttls, tls, ssl, network, shell. +See also `imap-streams' and `imap-stream-alist'.") (defvoo nnimap-authenticator nil "How nnimap authenticate itself to the server. @@ -263,7 +285,8 @@ connect to a server that accept Kerberos login's but you haven't installed the `imtest' program or your machine isn't configured for Kerberos. -Possible choices: kerberos4, cram-md5, login, anonymous.") +Possible choices: gssapi, kerberos4, digest-md5, cram-md5, login, anonymous. +See also `imap-authenticators' and `imap-authenticator-alist'") (defvoo nnimap-directory (nnheader-concat gnus-directory "overview/") "Directory to keep NOV cache files for nnimap groups. @@ -379,12 +402,15 @@ just like \"ticked\" articles, in other IMAP clients.") If this is 'imap-mailbox-lsub, then use a server-side subscription list to restrict visible folders.") +(defcustom nnimap-debug nil + "If non-nil, random debug spews are placed in *nnimap-debug* buffer." + :group 'nnimap + :type 'boolean) + ;; Internal variables: +(defvar nnimap-debug-buffer "*nnimap-debug*") (defvar nnimap-mailbox-info (gnus-make-hashtable 997)) -(defvar nnimap-debug nil - "Name of buffer to record debugging info. -For example: (setq nnimap-debug \"*nnimap-debug*\")") (defvar nnimap-current-move-server nil) (defvar nnimap-current-move-group nil) (defvar nnimap-current-move-article nil) @@ -392,10 +418,6 @@ For example: (setq nnimap-debug \"*nnimap-debug*\")") (defvar nnimap-progress-chars '(?| ?/ ?- ?\\)) (defvar nnimap-progress-how-often 20) (defvar nnimap-counter) -(defvar nnimap-callback-callback-function nil - "Gnus callback the nnimap asynchronous callback should call.") -(defvar nnimap-callback-buffer nil - "Which buffer the asynchronous article prefetch callback should work in.") (defvar nnimap-server-buffer-alist nil) ;; Map server name to buffers. (defvar nnimap-current-server nil) ;; Current server (defvar nnimap-server-buffer nil) ;; Current servers' buffer @@ -457,7 +479,7 @@ If SERVER is nil, uses the current server." (imap-mailbox-unselect nnimap-server-buffer)))) (defun nnimap-find-minmax-uid (group &optional examine) - "Find lowest and highest active article nummber in GROUP. + "Find lowest and highest active article number in GROUP. If EXAMINE is non-nil the group is selected read-only." (with-current-buffer nnimap-server-buffer (when (or (string= group (imap-current-mailbox)) @@ -528,10 +550,7 @@ If EXAMINE is non-nil the group is selected read-only." (with-temp-buffer (buffer-disable-undo) (insert headers) - (nnheader-ms-strip-cr) - (nnheader-fold-continuation-lines) - (subst-char-in-region (point-min) (point-max) ?\t ? ) - (let ((head (nnheader-parse-head 'naked))) + (let ((head (nnheader-parse-naked-head))) (mail-header-set-number head uid) (mail-header-set-chars head chars) (mail-header-set-lines head lines) @@ -560,7 +579,7 @@ If EXAMINE is non-nil the group is selected read-only." articles)))) (defun nnimap-group-overview-filename (group server) - "Make pathname for GROUP on SERVER." + "Make file name for GROUP on SERVER." (let* ((dir (file-name-as-directory (expand-file-name nnimap-directory))) (uidvalidity (gnus-group-get-parameter (gnus-group-prefixed-name @@ -734,7 +753,12 @@ If EXAMINE is non-nil the group is selected read-only." (with-current-buffer (get-buffer-create nnimap-server-buffer) (nnoo-change-server 'nnimap server defs)) (or (and nnimap-server-buffer - (imap-opened nnimap-server-buffer)) + (imap-opened nnimap-server-buffer) + (if (with-current-buffer nnimap-server-buffer + (memq imap-state '(auth select examine))) + t + (imap-close nnimap-server-buffer) + (nnimap-open-connection server))) (nnimap-open-connection server)))) (deffoo nnimap-server-opened (&optional server) @@ -782,19 +806,26 @@ function is generally only called when Gnus is shutting down." 'identity) (or string ""))) -(defun nnimap-callback () - (remove-hook 'imap-fetch-data-hook 'nnimap-callback) - (with-current-buffer nnimap-callback-buffer - (insert - (with-current-buffer nnimap-server-buffer - (nnimap-demule - (if (imap-capability 'IMAP4rev1) - ;; xxx don't just use car? alist doesn't contain - ;; anything else now, but it might... - (nth 2 (car (imap-message-get (imap-current-message) 'BODYDETAIL))) - (imap-message-get (imap-current-message) 'RFC822))))) - (nnheader-ms-strip-cr) - (funcall nnimap-callback-callback-function t))) +(defun nnimap-make-callback (article gnus-callback buffer) + "Return a callback function." + `(lambda () + (nnimap-callback ,article ,gnus-callback ,buffer))) + +(defun nnimap-callback (article gnus-callback buffer) + (when (eq article (imap-current-message)) + (remove-hook 'imap-fetch-data-hook + (nnimap-make-callback article gnus-callback buffer)) + (with-current-buffer buffer + (insert + (with-current-buffer nnimap-server-buffer + (nnimap-demule + (if (imap-capability 'IMAP4rev1) + ;; xxx don't just use car? alist doesn't contain + ;; anything else now, but it might... + (nth 2 (car (imap-message-get article 'BODYDETAIL))) + (imap-message-get article 'RFC822))))) + (nnheader-ms-strip-cr) + (funcall gnus-callback t)))) (defun nnimap-request-article-part (article part prop &optional group server to-buffer detail) @@ -805,7 +836,9 @@ function is generally only called when Gnus is shutting down." nnimap-server-buffer)) article))) (when article - (gnus-message 10 "nnimap: Fetching (part of) article %d..." article) + (gnus-message 10 "nnimap: Fetching (part of) article %d from %s..." + article (or group imap-current-mailbox + gnus-newsgroup-name)) (if (not nnheader-callback-function) (with-current-buffer (or to-buffer nntp-server-buffer) (erase-buffer) @@ -815,15 +848,19 @@ function is generally only called when Gnus is shutting down." (nth 2 (car data)) data)))) (nnheader-ms-strip-cr) - (gnus-message 10 "nnimap: Fetching (part of) article %d...done" - article) + (gnus-message + 10 "nnimap: Fetching (part of) article %d from %s...done" + article (or group imap-current-mailbox gnus-newsgroup-name)) (if (bobp) - (nnheader-report 'nnimap "No such article: %s" + (nnheader-report 'nnimap "No such article %d in %s: %s" + article (or group imap-current-mailbox + gnus-newsgroup-name) (imap-error-text nnimap-server-buffer)) (cons group article))) - (add-hook 'imap-fetch-data-hook 'nnimap-callback) - (setq nnimap-callback-callback-function nnheader-callback-function - nnimap-callback-buffer nntp-server-buffer) + (add-hook 'imap-fetch-data-hook + (nnimap-make-callback article + nnheader-callback-function + nntp-server-buffer)) (imap-fetch-asynch article part nil nnimap-server-buffer) (cons group article)))))) @@ -871,10 +908,22 @@ function is generally only called when Gnus is shutting down." (nnheader-report 'nnimap "Group %s selected" group) t))))) +(defun nnimap-update-unseen (group &optional server) + "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) + nnimap-mailbox-info))) + (list (nth 0 old) (nth 1 old) + (imap-mailbox-status group 'unseen nnimap-server-buffer) + (nth 3 old))) + nnimap-mailbox-info)) + (defun nnimap-close-group (group &optional server) (with-current-buffer nnimap-server-buffer (when (and (imap-opened) (nnimap-possibly-change-group group server)) + (nnimap-update-unseen group server) (case nnimap-expunge-on-close (always (progn (imap-mailbox-expunge nnimap-close-asynchronous) @@ -969,29 +1018,40 @@ function is generally only called when Gnus is shutting down." (if (null nnimap-retrieve-groups-asynchronous) (setq slowgroups groups) (dolist (group groups) - (gnus-message 7 "nnimap: Checking mailbox %s" group) - (add-to-list (if (gnus-gethash-safe (concat server group) - nnimap-mailbox-info) + (gnus-message 9 "nnimap: Quickly checking mailbox %s" group) + (add-to-list (if (gnus-gethash-safe + (gnus-group-prefixed-name group server) + nnimap-mailbox-info) 'asyncgroups 'slowgroups) (list group (imap-mailbox-status-asynch - group 'uidnext nnimap-server-buffer)))) + group '(uidvalidity uidnext unseen) + nnimap-server-buffer)))) (dolist (asyncgroup asyncgroups) (let ((group (nth 0 asyncgroup)) (tag (nth 1 asyncgroup)) new old) (when (imap-ok-p (imap-wait-for-tag tag nnimap-server-buffer)) - (if (nnimap-string-lessp-numerical - (car (gnus-gethash - (concat server group) nnimap-mailbox-info)) - (imap-mailbox-get 'uidnext group nnimap-server-buffer)) + (if (or (not (string= + (nth 0 (gnus-gethash (gnus-group-prefixed-name + group server) + nnimap-mailbox-info)) + (imap-mailbox-get 'uidvalidity group + nnimap-server-buffer))) + (not (string= + (nth 1 (gnus-gethash (gnus-group-prefixed-name + group server) + nnimap-mailbox-info)) + (imap-mailbox-get 'uidnext group + nnimap-server-buffer)))) (push (list group) slowgroups) - (insert (cdr (gnus-gethash (concat server group) - nnimap-mailbox-info)))))))) + (insert (nth 3 (gnus-gethash (gnus-group-prefixed-name + group server) + nnimap-mailbox-info)))))))) (dolist (group slowgroups) (if nnimap-retrieve-groups-asynchronous (setq group (car group))) - (gnus-message 7 "nnimap: Rechecking mailbox %s" group) + (gnus-message 7 "nnimap: Mailbox %s modified" group) (imap-mailbox-put 'uidnext nil group nnimap-server-buffer) (or (member "\\NoSelect" (imap-mailbox-get 'list-flags group nnimap-server-buffer)) @@ -1006,11 +1066,19 @@ function is generally only called when Gnus is shutting down." (insert str) (when nnimap-retrieve-groups-asynchronous (gnus-sethash - (concat server group) - (cons (or (imap-mailbox-get + (gnus-group-prefixed-name group server) + (list (or (imap-mailbox-get + 'uidvalidity group nnimap-server-buffer) + (imap-mailbox-status + group 'uidvalidity nnimap-server-buffer)) + (or (imap-mailbox-get 'uidnext group nnimap-server-buffer) (imap-mailbox-status group 'uidnext nnimap-server-buffer)) + (or (imap-mailbox-get + 'unseen group nnimap-server-buffer) + (imap-mailbox-status + group 'unseen nnimap-server-buffer)) str) nnimap-mailbox-info))))))) (gnus-message 5 "nnimap: Checking mailboxes...done") @@ -1201,7 +1269,12 @@ 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 (nnimap-request-head article) + (when (if (if (eq nnimap-split-download-body 'default) + nnimap-split-download-body-default + nnimap-split-download-body) + (and (nnimap-request-article article) + (with-current-buffer nntp-server-buffer (mail-narrow-to-head))) + (nnimap-request-head article)) ;; copy article to right group(s) (setq removeorig nil) (dolist (to-group (nnimap-split-to-groups rule)) @@ -1216,15 +1289,19 @@ 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))))) ;; 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 (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 (imap-message-flags-add (format "%d" article) @@ -1249,7 +1326,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 @@ -1269,7 +1346,9 @@ function is generally only called when Gnus is shutting down." (deffoo nnimap-request-create-group (group &optional server args) (when (nnimap-possibly-change-server server) (or (imap-mailbox-status group 'uidvalidity nnimap-server-buffer) - (imap-mailbox-create group nnimap-server-buffer)))) + (imap-mailbox-create group nnimap-server-buffer) + (nnheader-report 'nnimap "%S" + (imap-error-text nnimap-server-buffer))))) (defun nnimap-time-substract (time1 time2) "Return TIME for TIME1 - TIME2." @@ -1298,8 +1377,8 @@ function is generally only called when Gnus is shutting down." (defun nnimap-expiry-target (arts group server) (unless (eq nnmail-expiry-target 'delete) (with-temp-buffer - (dolist (art (gnus-uncompress-sequence arts)) - (nnimap-request-article art group server (current-buffer)) + (dolist (art arts) + (nnimap-request-article art group server (current-buffer)) ;; hints for optimization in `nnimap-request-accept-article' (let ((nnimap-current-move-article art) (nnimap-current-move-group group) @@ -1314,35 +1393,34 @@ function is generally only called when Gnus is shutting down." (let ((artseq (gnus-compress-sequence articles))) (when (and artseq (nnimap-possibly-change-group group server)) (with-current-buffer nnimap-server-buffer - (if force - (progn - (nnimap-expiry-target artseq group server) - (when (imap-message-flags-add (imap-range-to-message-set artseq) - "\\Deleted") - (setq articles nil))) - (let ((days (or (and nnmail-expiry-wait-function - (funcall nnmail-expiry-wait-function group)) - nnmail-expiry-wait))) - (cond ((eq days 'immediate) - (nnimap-expiry-target artseq group server) - (when (imap-message-flags-add - (imap-range-to-message-set artseq) "\\Deleted") - (setq articles nil))) - ((numberp days) - (let ((oldarts (imap-search - (format nnimap-expunge-search-string - (imap-range-to-message-set artseq) - (nnimap-date-days-ago days)))) - (imap-fetch-data-hook - '(nnimap-request-expire-articles-progress))) + (let ((days (or (and nnmail-expiry-wait-function + (funcall nnmail-expiry-wait-function group)) + nnmail-expiry-wait))) + (cond ((or force (eq days 'immediate)) + (let ((oldarts (imap-search + (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 + (gnus-compress-sequence oldarts)) "\\Deleted") + (setq articles (gnus-set-difference + articles oldarts)))))) + ((numberp days) + (let ((oldarts (imap-search + (format nnimap-expunge-search-string + (imap-range-to-message-set artseq) + (nnimap-date-days-ago days)))) + (imap-fetch-data-hook + '(nnimap-request-expire-articles-progress))) + (when oldarts (nnimap-expiry-target oldarts group server) - (and oldarts - (imap-message-flags-add - (imap-range-to-message-set - (gnus-compress-sequence oldarts)) - "\\Deleted") - (setq articles (gnus-set-difference - articles oldarts))))))))))) + (when (imap-message-flags-add + (imap-range-to-message-set + (gnus-compress-sequence oldarts)) "\\Deleted") + (setq articles (gnus-set-difference + articles oldarts))))))))))) ;; return articles not deleted articles) @@ -1385,7 +1463,7 @@ function is generally only called when Gnus is shutting down." ;; remove any 'From blabla' lines, some IMAP servers ;; reject the entire message otherwise. (when (looking-at "^From[^:]") - (kill-region (point) (progn (forward-line) (point)))) + (delete-region (point) (progn (forward-line) (point)))) ;; turn into rfc822 format (\r\n eol's) (while (search-forward "\n" nil t) (replace-match "\r\n")) @@ -1522,8 +1600,8 @@ be used in a STORE FLAGS command." (when nnimap-debug (require 'trace) - (buffer-disable-undo (get-buffer-create nnimap-debug)) - (mapcar (lambda (f) (trace-function-background f nnimap-debug)) + (buffer-disable-undo (get-buffer-create nnimap-debug-buffer)) + (mapcar (lambda (f) (trace-function-background f nnimap-debug-buffer)) '( nnimap-possibly-change-server nnimap-verify-uidvalidity