X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fnnimap.el;h=0e27d37103f74423489f4e11639c4ee2034fdf26;hp=b5c6c1d19974a6277dfb81aa3cc05fe576fafa83;hb=125d88b46ad2efa065f06d5dac37a245b488985a;hpb=0df880a6a1f5caeb11806275b6d4e2bfb09e27ad diff --git a/lisp/nnimap.el b/lisp/nnimap.el index b5c6c1d19..0e27d3710 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, @@ -55,6 +56,7 @@ ;; o What about Gnus's article editing, can we support it? NO! ;; o Use \Draft to support the draft group?? ;; o Duplicate suppression +;; o Rewrite UID SEARCH UID X as UID FETCH X (UID) for those with slow servers ;;; Code: @@ -68,6 +70,8 @@ (require 'gnus-start) (require 'gnus-int) +(eval-when-compile (require 'cl)) + (nnoo-declare nnimap) (defconst nnimap-version "nnimap 1.0") @@ -81,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 @@ -114,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'. @@ -126,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 @@ -190,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 @@ -241,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. @@ -262,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. @@ -279,9 +303,12 @@ typical complete file name would be (defvoo nnimap-nov-file-name-suffix ".novcache" "Suffix for NOV cache base filename.") -(defvoo nnimap-nov-is-evil nil - "If non-nil, nnimap will never generate or use a local nov database for this backend. -Using nov databases will speed up header fetching considerably. +(defvoo nnimap-nov-is-evil gnus-agent + "If non-nil, never generate or use a local nov database for this backend. +Using nov databases should speed up header fetching considerably. +However, it will invoke a UID SEARCH UID command on the server, and +some servers implement this command inefficiently by opening each and +every message in the group, thus making it quite slow. Unlike other backends, you do not need to take special care if you flip this variable.") @@ -375,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: -(defvoo 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-debug-buffer "*nnimap-debug*") +(defvar nnimap-mailbox-info (gnus-make-hashtable 997)) (defvar nnimap-current-move-server nil) (defvar nnimap-current-move-group nil) (defvar nnimap-current-move-article nil) @@ -388,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 @@ -453,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)) @@ -524,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) @@ -556,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 @@ -697,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) @@ -730,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) @@ -762,8 +830,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) @@ -778,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) @@ -801,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) @@ -811,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)))))) @@ -867,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) @@ -938,6 +1031,23 @@ function is generally only called when Gnus is shutting down." ;; Optional backend functions +(defun nnimap-string-lessp-numerical (s1 s2) + "Return t if first arg string is less than second in numerical order." + (cond ((string= s1 s2) + nil) + ((> (length s1) (length s2)) + nil) + ((< (length s1) (length s2)) + t) + ((< (string-to-number (substring s1 0 1)) + (string-to-number (substring s2 0 1))) + t) + ((> (string-to-number (substring s1 0 1)) + (string-to-number (substring s2 0 1))) + nil) + (t + (nnimap-string-lessp-numerical (substring s1 1) (substring s2 1))))) + (deffoo nnimap-retrieve-groups (groups &optional server) (when (nnimap-possibly-change-server server) (gnus-message 5 "nnimap: Checking mailboxes...") @@ -948,45 +1058,69 @@ 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 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 (< (car (gnus-gethash 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 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)) - (let ((info (nnimap-find-minmax-uid group 'examine))) + (let* ((info (nnimap-find-minmax-uid group 'examine)) + (str (format "\"%s\" %d %d y\n" group + (or (nth 2 info) 0) + (max 1 (or (nth 1 info) 1))))) (when (> (or (imap-mailbox-get 'recent group nnimap-server-buffer) 0) 0) (push (list (cons group 0)) nnmail-split-history)) - (insert - (cdr + (insert str) + (when nnimap-retrieve-groups-asynchronous (gnus-sethash - 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)) - (format "\"%s\" %d %d y\n" group - (or (nth 2 info) 0) - (max 1 (or (nth 1 info) 1)))) - nnimap-mailbox-info)))))))) + (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") 'active)) @@ -1084,11 +1218,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 @@ -1128,7 +1262,10 @@ function is generally only called when Gnus is shutting down." (goto-char (point-min)) (when (and (if (stringp regexp) (progn - (setq regrepp (string-match "\\\\[0-9&]" group)) + (if (not (stringp group)) + (setq group (eval group)) + (setq regrepp + (string-match "\\\\[0-9&]" group))) (re-search-forward regexp nil t)) (funcall regexp group)) ;; Don't enter the article into the same group twice. @@ -1172,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)) @@ -1187,13 +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 - (nnmail-cache-insert (nnmail-fetch-field - "message-id") to-group))) + (let (msgid) + (and (setq msgid + (nnmail-fetch-field "message-id")) + (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) @@ -1218,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 @@ -1238,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." @@ -1267,8 +1419,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) @@ -1283,35 +1435,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) @@ -1354,12 +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")))) + (nnmail-cache-insert (nnmail-fetch-field "message-id") + group + (nnmail-fetch-field "subject")))) (when (and last nnmail-cache-accepted-message-ids) (nnmail-cache-close)) ;; this 'or' is for Cyrus server bug @@ -1398,21 +1551,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))) @@ -1490,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 @@ -1552,4 +1705,5 @@ be used in a STORE FLAGS command." (provide 'nnimap) +;; arch-tag: 2b001f20-3ff9-4094-a0ad-46807c1ba70b ;;; nnimap.el ends here