X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnnimap.el;h=1e170d834c23bb1fa074d1c52c621feeb8f01cf6;hb=609e9daf5a06f5d39ca20cc6718f72a414866870;hp=c824e88dc6f03fe90f521cf4136fd090f43fd306;hpb=fa19a070ef0d1d38dcaca155e920b932920b995f;p=gnus diff --git a/lisp/nnimap.el b/lisp/nnimap.el index c824e88dc..1e170d834 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'. @@ -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,52 @@ 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-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." + :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 +455,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 +516,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 +587,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 +616,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 @@ -701,15 +757,18 @@ If EXAMINE is non-nil the group is selected read-only." (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")) + (alist (or (gnus-netrc-machine list server port "imap") + (gnus-netrc-machine list + (or nnimap-server-address + nnimap-address) + port "imap"))) (user (gnus-netrc-get alist "login")) (passwd (gnus-netrc-get alist "password"))) (if (imap-authenticate user passwd nnimap-server-buffer) (prog1 (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) @@ -734,7 +793,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 +846,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 +876,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 +888,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 +948,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 +1058,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 +1106,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 +1309,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 +1329,21 @@ 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 (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 +1368,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 +1388,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." @@ -1322,11 +1443,12 @@ function is generally only called when Gnus is shutting down." (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 oldarts) "\\Deleted") - (setq articles (gnus-set-difference - articles 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 @@ -1335,11 +1457,12 @@ function is generally only called when Gnus is shutting down." (imap-fetch-data-hook '(nnimap-request-expire-articles-progress))) (when oldarts - (nnimap-expiry-target oldarts group server)) - (when (imap-message-flags-add - (imap-range-to-message-set oldarts) "\\Deleted") - (setq articles (gnus-set-difference - articles 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))))))))))) ;; return articles not deleted articles) @@ -1382,13 +1505,14 @@ 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")) (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 @@ -1519,8 +1643,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