X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnnimap.el;h=092641461176decf024fa40f1ebbe6acf95c9227;hb=ee4a7be24fb6982b5baa5eafb65178ccaca6df50;hp=75814790c329480fef719a643e21e06338951f75;hpb=ae3801f1c2bb1435902644c89d21affb0d221c7c;p=gnus diff --git a/lisp/nnimap.el b/lisp/nnimap.el index 75814790c..092641461 100644 --- a/lisp/nnimap.el +++ b/lisp/nnimap.el @@ -1,5 +1,5 @@ ;;; nnimap.el --- imap backend for Gnus -;; Copyright (C) 1998,1999 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. ;; Author: Simon Josefsson ;; Jim Radford @@ -37,7 +37,6 @@ ;; Todo, minor things: ;; ;; o Don't require half of Gnus -- backends should be standalone -;; o Support escape characters in `message-tokenize-header' ;; o Verify that we don't use IMAP4rev1 specific things (RFC2060 App B) ;; o Dont uid fetch 1,* in nnimap-retrive-groups (slow) ;; o Split up big fetches (1,* header especially) in smaller chunks @@ -55,12 +54,11 @@ ;; .newsrc.eld) ;; o What about Gnus's article editing, can we support it? NO! ;; o Use \Draft to support the draft group?? +;; o Duplicate suppression ;;; Code: -(eval-and-compile - (require 'imap)) - +(require 'imap) (require 'nnoo) (require 'nnmail) (require 'nnheader) @@ -72,7 +70,11 @@ (nnoo-declare nnimap) -(defconst nnimap-version "nnimap 0.131") +(defconst nnimap-version "nnimap 1.0") + +(defgroup nnimap nil + "Reading IMAP mail with Gnus." + :group 'gnus) (defvoo nnimap-address nil "Address of physical IMAP server. If nil, use the virtual server's name.") @@ -83,20 +85,36 @@ If nil, defaults to 993 for SSL connections and 143 otherwise.") ;; Splitting variables -(defvar nnimap-split-crosspost t +(defcustom nnimap-split-crosspost t "If non-nil, do crossposting if several split methods match the mail. -If nil, the first match found will be used.") +If nil, the first match found will be used." + :group 'nnimap + :type 'boolean) -(defvar nnimap-split-inbox nil - "*Name of mailbox to split mail from. +(defcustom nnimap-split-inbox nil + "Name of mailbox to split mail from. Mail is read from this mailbox and split according to rules in -`nnimap-split-rules'. +`nnimap-split-rule'. + +This can be a string or a list of strings." + :group 'nnimap + :type '(choice (string) + (repeat string))) + +(define-widget 'nnimap-strict-function 'function + "This widget only matches values that are functionp. + +Warning: This means that a value that is the symbol of a not yet +loaded function will not match. Use with care." + :match 'nnimap-strict-function-match) -This can be a string or a list of strings.") +(defun nnimap-strict-function-match (widget value) + "Ignoring WIDGET, match if VALUE is a function." + (functionp value)) -(defvar nnimap-split-rule nil - "*Mail will be split according to theese rules. +(defcustom nnimap-split-rule nil + "Mail will be split according to theese rules. Mail is read from mailbox(es) specified in `nnimap-split-inbox'. @@ -105,7 +123,7 @@ If you'd like, for instance, one mail group for mail from the everything else in the incoming mailbox, you could do something like this: -(setq nnimap-split-rule '((\"INBOX.gnus-imap\" \"From:.*gnus-imap\") +\(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 @@ -113,10 +131,6 @@ 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. -The first element can also be a list. In that case, the first element -is the server the second element is the group on that server in which -the matching article will be stored. - 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 the argument. It should return a non-nil value if it thinks that the @@ -124,10 +138,83 @@ mail belongs in that group. This variable can also have a function as its value, the function will be called with the headers narrowed and should return a group where it -thinks the article should be splitted to.") - -(defvar nnimap-split-fancy nil - "Like `nnmail-split-fancy', which see.") +thinks the article should be splitted to. See `nnimap-split-fancy'. + +To allow for different split rules on different virtual servers, and +even different split rules in different inboxes on the same server, +the syntax of this variable have been extended along the lines of: + +\(setq nnimap-split-rule + '((\"my1server\" (\".*\" ((\"ding\" \"ding@gnus.org\") + (\"junk\" \"From:.*Simon\"))) + (\"my2server\" (\"INBOX\" nnimap-split-fancy)) + (\"my[34]server\" (\".*\" ((\"private\" \"To:.*Simon\") + (\"junk\" my-junk-func))))) + +The virtual server name is in fact a regexp, so that the same rules +may apply to several servers. In the example, the servers +\"my3server\" and \"my4server\" both use the same rules. Similarly, +the inbox string is also a regexp. The actual splitting rules are as +before, either a function, or a list with group/regexp or +group/function elements." + :group 'nnimap + :type '(choice :tag "Rule type" + (repeat :menu-tag "Single-server" + :tag "Single-server list" + (list (string :tag "Mailbox") + (choice :tag "Predicate" + (regexp :tag "A regexp") + (nnimap-strict-function :tag "A function")))) + (choice :menu-tag "A function" + :tag "A function" + (function-item nnimap-split-fancy) + (function-item nnmail-split-fancy) + (nnimap-strict-function :tag "User-defined function")) + (repeat :menu-tag "Multi-server (extended)" + :tag "Multi-server list" + (list (regexp :tag "Server regexp") + (list (regexp :tag "Incoming Mailbox regexp") + (repeat :tag "Rules for matching server(s) and mailbox(es)" + (list (string :tag "Destination mailbox") + (choice :tag "Predicate" + (regexp :tag "A Regexp") + (nnimap-strict-function :tag "A Function"))))))))) + +(defcustom nnimap-split-predicate "UNSEEN UNDELETED" + "The predicate used to find articles to split. +If you use another IMAP client to peek on articles but always would +like nnimap to split them once it's started, you could change this to +\"UNDELETED\". Other available predicates are available in +RFC2060 section 6.4.4." + :group 'nnimap + :type 'string) + +(defcustom nnimap-split-fancy nil + "Like `nnmail-split-fancy', which see." + :group 'nnimap + :type 'sexp) + +;; Performance / bug workaround variables + +(defcustom nnimap-close-asynchronous t + "Close mailboxes asynchronously in `nnimap-close-group'. +This means that errors cought by nnimap when closing the mailbox will +not prevent Gnus from updating the group status, which may be harmful. +However, it increases speed." + :type 'boolean + :group 'nnimap) + +(defcustom nnimap-dont-close t + "Never close mailboxes. +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." + :type 'boolean + :group 'nnimap) + +(defvoo nnimap-need-unselect-to-notice-new-mail nil + "Unselect mailboxes before looking for new mail in them. +Some servers seem to need this under some circumstances.") ;; Authorization / Privacy variables @@ -215,7 +302,8 @@ There are two wildcards * and %. * matches everything, % matches everything in the current hierarchy.") (defvoo nnimap-news-groups nil - "IMAP support a news-like mode, also known as bulletin board mode, where replies is sent via IMAP instead of SMTP. + "IMAP support a news-like mode, also known as bulletin board mode, +where replies is sent via IMAP instead of SMTP. This variable should contain a regexp matching groups where you wish replies to be stored to the mailbox directly. @@ -230,6 +318,22 @@ news-like mailboxes. If you wish to have a group with todo items or similar which you wouldn't want to set up a mailing list for, you can use this to make replies go directly to the group.") +(defvoo nnimap-expunge-search-string "UID %s NOT SINCE %s" + "IMAP search command to use for articles that are to be expired. +The first %s is replaced by a UID set of articles to search on, +and the second %s is replaced by a date criterium. + +One useful (and perhaps the only useful) value to change this to would +be `UID %s NOT SENTSINCE %s' to make nnimap use the Date: header +instead of the internal date of messages. See section 6.4.4 of RFC +2060 for more information on valid strings.") + +(defvoo nnimap-importantize-dormant t + "If non-nil, mark \"dormant\" articles as \"ticked\" for other IMAP clients. +Note that within Gnus, dormant articles will still (only) be +marked as ticked. This is to make \"dormant\" articles stand out, +just like \"ticked\" articles, in other IMAP clients.") + (defvoo nnimap-server-address nil "Obsolete. Use `nnimap-address'.") @@ -261,7 +365,9 @@ restrict visible folders.") ;; Internal variables: -(defvar nnimap-debug nil);; "*nnimap-debug*") +(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) @@ -274,8 +380,8 @@ restrict visible folders.") (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 +(defvar nnimap-current-server nil) ;; Current server +(defvar nnimap-server-buffer nil) ;; Current servers' buffer @@ -299,20 +405,46 @@ If SERVER is nil, uses the current server." group (gnus-server-to-method (format "nnimap:%s" server)))) (new-uidvalidity (imap-mailbox-get 'uidvalidity)) - (old-uidvalidity (gnus-group-get-parameter gnusgroup 'uidvalidity))) + (old-uidvalidity (gnus-group-get-parameter gnusgroup 'uidvalidity)) + (dir (file-name-as-directory (expand-file-name nnimap-directory))) + (nameuid (nnheader-translate-file-chars + (concat nnimap-nov-file-name + (if (equal server "") + "unnamed" + server) "." group "." old-uidvalidity + nnimap-nov-file-name-suffix) t)) + (file (if (or nnmail-use-long-file-names + (file-exists-p (expand-file-name nameuid dir))) + (expand-file-name nameuid dir) + (expand-file-name + (mm-encode-coding-string + (nnheader-replace-chars-in-string nameuid ?. ?/) + nnmail-pathname-coding-system) + dir)))) (if old-uidvalidity (if (not (equal old-uidvalidity new-uidvalidity)) - nil ;; uidvalidity clash + ;; uidvalidity clash + (gnus-delete-file file) (gnus-group-set-parameter gnusgroup 'uidvalidity new-uidvalidity) t) (gnus-group-add-parameter gnusgroup (cons 'uidvalidity new-uidvalidity)) t))) +(defun nnimap-before-find-minmax-bugworkaround () + "Function called before iterating through mailboxes with +`nnimap-find-minmax-uid'." + (when nnimap-need-unselect-to-notice-new-mail + ;; XXX this is for UoW imapd problem, it doesn't notice new mail in + ;; currently selected mailbox without a re-select/examine. + (or (null (imap-current-mailbox nnimap-server-buffer)) + (imap-mailbox-unselect nnimap-server-buffer)))) + (defun nnimap-find-minmax-uid (group &optional examine) "Find lowest and highest active article nummber in GROUP. If EXAMINE is non-nil the group is selected read-only." (with-current-buffer nnimap-server-buffer - (when (imap-mailbox-select group examine) + (when (or (string= group (imap-current-mailbox)) + (imap-mailbox-select group examine)) (let (minuid maxuid) (when (> (imap-mailbox-get 'exists) 0) (imap-fetch "1,*" "UID" nil 'nouidfetch) @@ -321,7 +453,7 @@ If EXAMINE is non-nil the group is selected read-only." maxuid (if maxuid (max maxuid uid) uid))) 'UID)) (list (imap-mailbox-get 'exists) minuid maxuid))))) - + (defun nnimap-possibly-change-group (group &optional server) "Make GROUP the current group, and SERVER the current server." (when (nnimap-possibly-change-server server) @@ -332,12 +464,14 @@ If EXAMINE is non-nil the group is selected read-only." (if (or (nnimap-verify-uidvalidity group (or server nnimap-current-server)) (zerop (imap-mailbox-get 'exists group)) + t ;; for OGnus to see if ignoring uidvalidity + ;; changes has any bad effects. (yes-or-no-p (format "nnimap: Group %s is not uidvalid. Continue? " group))) imap-current-mailbox (imap-mailbox-unselect) - (error "nnimap: Group %s is not uid-valid." group)) + (error "nnimap: Group %s is not uid-valid" group)) (nnheader-report 'nnimap (imap-error-text))))))) (defun nnimap-replace-whitespace (string) @@ -361,14 +495,16 @@ If EXAMINE is non-nil the group is selected read-only." nnimap-progress-how-often) nnimap-progress-chars))) (with-current-buffer nntp-server-buffer - (let (headers lines chars uid) + (let (headers lines chars uid mbx) (with-current-buffer nnimap-server-buffer (setq uid imap-current-message - headers (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 uid 'BODYDETAIL))) - (imap-message-get uid 'RFC822.HEADER)) + mbx imap-current-mailbox + headers (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 uid 'BODYDETAIL))) + (imap-message-get uid 'RFC822.HEADER))) lines (imap-body-lines (imap-message-body imap-current-message)) chars (imap-message-get imap-current-message 'RFC822.SIZE))) (nnheader-insert-nov @@ -376,10 +512,14 @@ If EXAMINE is non-nil the group is selected read-only." (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))) (mail-header-set-number head uid) (mail-header-set-chars head chars) (mail-header-set-lines head lines) + (mail-header-set-xref + head (format "%s %s:%d" (system-name) mbx uid)) head)))))) (defun nnimap-retrieve-which-headers (articles fetch-old) @@ -388,7 +528,7 @@ If EXAMINE is non-nil the group is selected read-only." (if (numberp (car-safe articles)) (imap-search (concat "UID " - (nnimap-range-to-string + (imap-range-to-message-set (gnus-compress-sequence (append (gnus-uncompress-sequence (and fetch-old @@ -399,23 +539,53 @@ If EXAMINE is non-nil the group is selected read-only." articles))))) (mapcar (lambda (msgid) (imap-search - (format "HEADER Message-Id %s" msgid))) + (format "HEADER Message-Id \"%s\"" msgid))) articles)))) (defun nnimap-group-overview-filename (group server) "Make pathname for GROUP on SERVER." - (let ((dir (file-name-as-directory (expand-file-name nnimap-directory))) - (file (nnheader-translate-file-chars - (concat nnimap-nov-file-name - (if (equal server "") - "unnamed" - server) "." group nnimap-nov-file-name-suffix) t))) - (if (or nnmail-use-long-file-names - (file-exists-p (concat dir file))) - (concat dir file) - (concat dir (mm-encode-coding-string - (nnheader-replace-chars-in-string file ?. ?/) - nnmail-pathname-coding-system))))) + (let* ((dir (file-name-as-directory (expand-file-name nnimap-directory))) + (uidvalidity (gnus-group-get-parameter + (gnus-group-prefixed-name + group (gnus-server-to-method + (format "nnimap:%s" server))) + 'uidvalidity)) + (name (nnheader-translate-file-chars + (concat nnimap-nov-file-name + (if (equal server "") + "unnamed" + server) "." group nnimap-nov-file-name-suffix) t)) + (nameuid (nnheader-translate-file-chars + (concat nnimap-nov-file-name + (if (equal server "") + "unnamed" + server) "." group "." uidvalidity + nnimap-nov-file-name-suffix) t)) + (oldfile (if (or nnmail-use-long-file-names + (file-exists-p (expand-file-name name dir))) + (expand-file-name name dir) + (expand-file-name + (mm-encode-coding-string + (nnheader-replace-chars-in-string name ?. ?/) + nnmail-pathname-coding-system) + dir))) + (newfile (if (or nnmail-use-long-file-names + (file-exists-p (expand-file-name nameuid dir))) + (expand-file-name nameuid dir) + (expand-file-name + (mm-encode-coding-string + (nnheader-replace-chars-in-string nameuid ?. ?/) + nnmail-pathname-coding-system) + dir)))) + (when (and (file-exists-p oldfile) (not (file-exists-p newfile))) + (message "nnimap: Upgrading novcache filename...") + (sit-for 1) + (gnus-make-directory (file-name-directory newfile)) + (unless (ignore-errors (rename-file oldfile newfile) t) + (if (ignore-errors (copy-file oldfile newfile) t) + (delete-file oldfile) + (error "Can't rename `%s' to `%s'" oldfile newfile)))) + newfile)) (defun nnimap-retrieve-headers-from-file (group server) (with-current-buffer nntp-server-buffer @@ -423,13 +593,11 @@ If EXAMINE is non-nil the group is selected read-only." (when (file-exists-p nov) (mm-insert-file-contents nov) (set-buffer-modified-p nil) - (let ((min (progn (goto-char (point-min)) - (when (not (eobp)) - (read (current-buffer))))) - (max (progn (goto-char (point-max)) - (forward-line -1) - (when (not (bobp)) - (read (current-buffer)))))) + (let ((min (ignore-errors (goto-char (point-min)) + (read (current-buffer)))) + (max (ignore-errors (goto-char (point-max)) + (forward-line -1) + (read (current-buffer))))) (if (and (numberp min) (numberp max)) (cons min max) ;; junk, remove it, it's saved later @@ -441,7 +609,7 @@ If EXAMINE is non-nil the group is selected read-only." (let ((imap-fetch-data-hook '(nnimap-retrieve-headers-progress)) (nnimap-length (gnus-range-length articles)) (nnimap-counter 0)) - (imap-fetch (nnimap-range-to-string articles) + (imap-fetch (imap-range-to-message-set articles) (concat "(UID RFC822.SIZE BODY " (let ((headers (append '(Subject From Date Message-Id @@ -455,7 +623,7 @@ If EXAMINE is non-nil the group is selected read-only." (> nnimap-length nnmail-large-newsgroup) (nnheader-message 6 "nnimap: Retrieving headers...done"))))) -(defun nnimap-use-nov-p (group server) +(defun nnimap-dont-use-nov-p (group server) (or gnus-nov-is-evil nnimap-nov-is-evil (unless (and (gnus-make-directory (file-name-directory @@ -469,7 +637,7 @@ If EXAMINE is non-nil the group is selected read-only." (when (nnimap-possibly-change-group group server) (with-current-buffer nntp-server-buffer (erase-buffer) - (if (nnimap-use-nov-p group server) + (if (nnimap-dont-use-nov-p group server) (nnimap-retrieve-headers-from-server (gnus-compress-sequence articles) group server) (let (uids cached low high) @@ -489,7 +657,7 @@ If EXAMINE is non-nil the group is selected read-only." (nnimap-retrieve-headers-from-server (cons (1+ (cdr cached)) high) group server)) (when nnimap-prune-cache - ;; remove nov's for articles which has expired on server + ;; remove nov's for articles which has expired on server (goto-char (point-min)) (dolist (uid (gnus-set-difference articles uids)) (when (re-search-forward (format "^%d\t" uid) nil t) @@ -512,15 +680,15 @@ 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 alist user passwd) - (and (fboundp 'gnus-parse-netrc) - (setq list (gnus-parse-netrc nnimap-authinfo-file) - alist (or (and (gnus-netrc-get - (gnus-netrc-machine list server) "machine") - (gnus-netrc-machine list server)) - (gnus-netrc-machine list nnimap-address)) - user (gnus-netrc-get alist "login") - passwd (gnus-netrc-get alist "password"))) + (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"))) (if (imap-authenticate user passwd nnimap-server-buffer) (prog1 (push (list server nnimap-server-buffer) @@ -544,6 +712,10 @@ If EXAMINE is non-nil the group is selected read-only." (cadr (assq 'nnimap-server-address defs))) defs) (push (list 'nnimap-address server) defs))) (nnoo-change-server 'nnimap server defs) + (or nnimap-server-buffer + (setq nnimap-server-buffer (cadr (assq 'nnimap-server-buffer defs)))) + (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)) (nnimap-open-connection server)))) @@ -598,27 +770,35 @@ function is generally only called when Gnus is shutting down." (with-current-buffer nnimap-callback-buffer (insert (with-current-buffer nnimap-server-buffer - (nnimap-demule (imap-message-get (imap-current-message) 'RFC822)))) ;xxx + (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-request-article-part (article part prop - &optional group server to-buffer) +(defun nnimap-request-article-part (article part prop &optional + group server to-buffer detail) (when (nnimap-possibly-change-group group server) (let ((article (if (stringp article) (car-safe (imap-search - (format "HEADER Message-Id %s" article) + (format "HEADER Message-Id \"%s\"" article) nnimap-server-buffer)) article))) (when article - (gnus-message 9 "nnimap: Fetching (part of) article %d..." article) + (gnus-message 10 "nnimap: Fetching (part of) article %d..." article) (if (not nnheader-callback-function) (with-current-buffer (or to-buffer nntp-server-buffer) (erase-buffer) - (insert (nnimap-demule (imap-fetch article part prop nil - nnimap-server-buffer))) + (let ((data (imap-fetch article part prop nil + nnimap-server-buffer))) + (insert (nnimap-demule (if detail + (nth 2 (car data)) + data)))) (nnheader-ms-strip-cr) - (gnus-message 9 "nnimap: Fetching (part of) article %d...done" + (gnus-message 10 "nnimap: Fetching (part of) article %d...done" article) (if (bobp) (nnheader-report 'nnimap "No such article: %s" @@ -634,16 +814,25 @@ function is generally only called when Gnus is shutting down." t) (deffoo nnimap-request-article (article &optional group server to-buffer) - (nnimap-request-article-part - article "RFC822.PEEK" 'RFC822 group server to-buffer)) + (if (imap-capability 'IMAP4rev1 nnimap-server-buffer) + (nnimap-request-article-part + article "BODY.PEEK[]" 'BODYDETAIL group server to-buffer 'detail) + (nnimap-request-article-part + article "RFC822.PEEK" 'RFC822 group server to-buffer))) (deffoo nnimap-request-head (article &optional group server to-buffer) - (nnimap-request-article-part - article "RFC822.HEADER" 'RFC822.HEADER group server to-buffer)) + (if (imap-capability 'IMAP4rev1 nnimap-server-buffer) + (nnimap-request-article-part + article "BODY.PEEK[HEADER]" 'BODYDETAIL group server to-buffer 'detail) + (nnimap-request-article-part + article "RFC822.HEADER" 'RFC822.HEADER group server to-buffer))) (deffoo nnimap-request-body (article &optional group server to-buffer) - (nnimap-request-article-part - article "RFC822.TEXT.PEEK" 'RFC822.TEXT group server to-buffer)) + (if (imap-capability 'IMAP4rev1 nnimap-server-buffer) + (nnimap-request-article-part + article "BODY.PEEK[TEXT]" 'BODYDETAIL group server to-buffer 'detail) + (nnimap-request-article-part + article "RFC822.TEXT.PEEK" 'RFC822.TEXT group server to-buffer))) (deffoo nnimap-request-group (group &optional server fast) (nnimap-request-update-info-internal @@ -652,6 +841,7 @@ function is generally only called when Gnus is shutting down." group (gnus-server-to-method (format "nnimap:%s" server)))) server) (when (nnimap-possibly-change-group group server) + (nnimap-before-find-minmax-bugworkaround) (let (info) (cond (fast group) ((null (setq info (nnimap-find-minmax-uid group t))) @@ -669,15 +859,18 @@ function is generally only called when Gnus is shutting down." (when (and (imap-opened) (nnimap-possibly-change-group group server)) (case nnimap-expunge-on-close - ('always (imap-mailbox-expunge) - (imap-mailbox-close)) - ('ask (if (and (imap-search "DELETED") - (gnus-y-or-n-p (format - "Expunge articles in group `%s'? " - imap-current-mailbox))) - (progn (imap-mailbox-expunge) - (imap-mailbox-close)) - (imap-mailbox-unselect))) + (always (progn + (imap-mailbox-expunge nnimap-close-asynchronous) + (unless nnimap-dont-close + (imap-mailbox-close nnimap-close-asynchronous)))) + (ask (if (and (imap-search "DELETED") + (gnus-y-or-n-p (format "Expunge articles in group `%s'? " + imap-current-mailbox))) + (progn + (imap-mailbox-expunge nnimap-close-asynchronous) + (unless nnimap-dont-close + (imap-mailbox-close nnimap-close-asynchronous))) + (imap-mailbox-unselect))) (t (imap-mailbox-unselect))) (not imap-current-mailbox)))) @@ -695,6 +888,7 @@ function is generally only called when Gnus is shutting down." (erase-buffer)) (gnus-message 5 "nnimap: Generating active list%s..." (if (> (length server) 0) (concat " for " server) "")) + (nnimap-before-find-minmax-bugworkaround) (with-current-buffer nnimap-server-buffer (dolist (pattern (nnimap-pattern-to-list-arguments nnimap-list-pattern)) (dolist (mbx (funcall nnimap-request-list-method @@ -703,17 +897,18 @@ function is generally only called when Gnus is shutting down." (let ((info (nnimap-find-minmax-uid mbx 'examine))) (when info (with-current-buffer nntp-server-buffer - (insert (format "\"%s\" %d %d y\n" - mbx (or (nth 2 info) 0) - (max 1 (or (nth 1 info) 1))))))))))) + (insert (format "\"%s\" %d %d y\n" + mbx (or (nth 2 info) 0) + (max 1 (or (nth 1 info) 1))))))))))) (gnus-message 5 "nnimap: Generating active list%s...done" (if (> (length server) 0) (concat " for " server) "")) t)) (deffoo nnimap-request-post (&optional server) (let ((success t)) - (dolist (mbx (message-tokenize-header - (message-fetch-field "Newsgroups")) success) + (dolist (mbx (message-unquote-tokens + (message-tokenize-header + (message-fetch-field "Newsgroups") ", ")) success) (let ((to-newsgroup (gnus-group-prefixed-name mbx gnus-command-method))) (or (gnus-active to-newsgroup) (gnus-activate-group to-newsgroup) @@ -735,11 +930,16 @@ function is generally only called when Gnus is shutting down." (gnus-message 5 "nnimap: Checking mailboxes...") (with-current-buffer nntp-server-buffer (erase-buffer) + (nnimap-before-find-minmax-bugworkaround) (dolist (group groups) (gnus-message 7 "nnimap: Checking mailbox %s" group) (or (member "\\NoSelect" (imap-mailbox-get 'list-flags group nnimap-server-buffer)) (let ((info (nnimap-find-minmax-uid group 'examine))) + (when (> (or (imap-mailbox-get 'recent group + nnimap-server-buffer) 0) + 0) + (push (list (cons group 0)) nnmail-split-history)) (insert (format "\"%s\" %d %d y\n" group (or (nth 2 info) 0) (max 1 (or (nth 1 info) 1)))))))) @@ -748,11 +948,11 @@ function is generally only called when Gnus is shutting down." (deffoo nnimap-request-update-info-internal (group info &optional server) (when (nnimap-possibly-change-group group server) - (when info;; xxx what does this mean? should we create a info? + (when info ;; xxx what does this mean? should we create a info? (with-current-buffer nnimap-server-buffer (gnus-message 5 "nnimap: Updating info for %s..." (gnus-info-group info)) - + (when (nnimap-mark-permanent-p 'read) (let (seen unseen) ;; read info could contain articles marked unread by other @@ -776,19 +976,33 @@ function is generally only called when Gnus is shutting down." (gnus-info-set-read info seen))) (mapcar (lambda (pred) - (when (and (nnimap-mark-permanent-p (cdr pred)) - (member (nnimap-mark-to-flag (cdr pred)) - (imap-mailbox-get 'flags))) + (when (or (eq (cdr pred) 'recent) + (and (nnimap-mark-permanent-p (cdr pred)) + (member (nnimap-mark-to-flag (cdr pred)) + (imap-mailbox-get 'flags)))) (gnus-info-set-marks info - (nnimap-update-alist-soft + (gnus-update-alist-soft (cdr pred) (gnus-compress-sequence (imap-search (nnimap-mark-to-predicate (cdr pred)))) (gnus-info-marks info)) t))) gnus-article-mark-lists) - + + (when nnimap-importantize-dormant + ;; nnimap mark dormant article as ticked too (for other clients) + ;; so we remove that mark for gnus since we support dormant + (gnus-info-set-marks + info + (gnus-update-alist-soft + 'tick + (gnus-remove-from-range + (cdr-safe (assoc 'tick (gnus-info-marks info))) + (cdr-safe (assoc 'dormant (gnus-info-marks info)))) + (gnus-info-marks info)) + t)) + (gnus-message 5 "nnimap: Updating info for %s...done" (gnus-info-group info)) @@ -809,11 +1023,22 @@ function is generally only called when Gnus is shutting down." (what (nth 1 action)) (cmdmarks (nth 2 action)) marks) + ;; bookmark can't be stored (not list/range + (setq cmdmarks (delq 'bookmark cmdmarks)) + ;; killed can't be stored (not list/range + (setq cmdmarks (delq 'killed cmdmarks)) + ;; unsent are for nndraft groups only + (setq cmdmarks (delq 'unsent cmdmarks)) ;; cache flags are pointless on the server (setq cmdmarks (delq 'cache cmdmarks)) - ;; flag dormant articles as ticked - (if (memq 'dormant cmdmarks) - (setq cmdmarks (cons 'tick cmdmarks))) + ;; seen flags are local to each gnus + (setq cmdmarks (delq 'seen cmdmarks)) + ;; recent marks can't be set + (setq cmdmarks (delq 'recent cmdmarks)) + (when nnimap-importantize-dormant + ;; flag dormant articles as ticked + (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 @@ -823,15 +1048,15 @@ function is generally only called when Gnus is shutting down." (when (and range marks) (cond ((eq what 'del) (imap-message-flags-del - (nnimap-range-to-string range) + (imap-range-to-message-set range) (nnimap-mark-to-flag marks nil t))) ((eq what 'add) (imap-message-flags-add - (nnimap-range-to-string range) + (imap-range-to-message-set range) (nnimap-mark-to-flag marks nil t))) ((eq what 'set) (imap-message-flags-set - (nnimap-range-to-string range) + (imap-range-to-message-set range) (nnimap-mark-to-flag marks nil t))))))) (gnus-message 7 "nnimap: Setting marks in %s...done" group)))) nil) @@ -862,7 +1087,7 @@ function is generally only called when Gnus is shutting down." (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. + ;; Don't enter the article into the same group twice. (not (assoc group to-groups))) (push (if regrepp (nnmail-expand-newtext group) @@ -870,9 +1095,22 @@ function is generally only called when Gnus is shutting down." to-groups) (or nnimap-split-crosspost (throw 'split-done to-groups)))))))))) - + +(defun nnimap-assoc-match (key alist) + (let (element) + (while (and alist (not element)) + (if (string-match (car (car alist)) key) + (setq element (car alist))) + (setq alist (cdr alist))) + element)) + (defun nnimap-split-find-rule (server inbox) - nnimap-split-rule) + (if (and (listp nnimap-split-rule) (listp (car nnimap-split-rule)) + (list (cdar nnimap-split-rule)) (listp (cadar nnimap-split-rule))) + ;; extended format + (cadr (nnimap-assoc-match inbox (cdr (nnimap-assoc-match + server nnimap-split-rule)))) + nnimap-split-rule)) (defun nnimap-split-find-inbox (server) (if (listp nnimap-split-inbox) @@ -885,30 +1123,34 @@ function is generally only called when Gnus is shutting down." (let (rule inbox removeorig (inboxes (nnimap-split-find-inbox server))) ;; iterate over inboxes (while (and (setq inbox (pop inboxes)) - (nnimap-possibly-change-group inbox));; SELECT + (nnimap-possibly-change-group inbox)) ;; SELECT ;; find split rule for this server / inbox (when (setq rule (nnimap-split-find-rule server inbox)) ;; iterate over articles - (dolist (article (imap-search "UNSEEN UNDELETED")) + (dolist (article (imap-search nnimap-split-predicate)) (when (nnimap-request-head article) ;; copy article to right group(s) (setq removeorig nil) (dolist (to-group (nnimap-split-to-groups rule)) - (if (imap-message-copy (number-to-string article) - to-group nil 'nocopyuid) - (progn - (message "IMAP split moved %s:%s:%d to %s" server inbox - article to-group) - (setq removeorig t) - ;; Add the group-art list to the history list. - (push (list (cons to-group 0)) nnmail-split-history)) - (message "IMAP split failed to move %s:%s:%d to %s" server - inbox article to-group))) + (cond ((eq to-group 'junk) + (message "IMAP split removed %s:%s:%d" server inbox + article) + (setq removeorig t)) + ((imap-message-copy (number-to-string article) + to-group nil 'nocopyuid) + (message "IMAP split moved %s:%s:%d to %s" server + inbox article to-group) + (setq removeorig t) + ;; 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)))) ;; remove article if it was successfully copied somewhere (and removeorig (imap-message-flags-add (format "%d" article) "\\Seen \\Deleted"))))) - (when (imap-mailbox-select inbox);; just in case + (when (imap-mailbox-select inbox) ;; just in case ;; todo: UID EXPUNGE (if available) to remove splitted articles (imap-mailbox-expunge) (imap-mailbox-close))) @@ -923,23 +1165,26 @@ function is generally only called when Gnus is shutting down." (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s..." (if (> (length server) 0) " on " "") server) (erase-buffer) + (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 "*" (car pattern) nil nnimap-server-buffer)) - (or (member-if (lambda (mailbox) - (string= (downcase mailbox) "\\noselect")) - (imap-mailbox-get 'list-flags mbx - nnimap-server-buffer)) + (or (catch 'found + (dolist (mailbox (imap-mailbox-get 'list-flags mbx + nnimap-server-buffer)) + (if (string= (downcase mailbox) "\\noselect") + (throw 'found t))) + nil) (let ((info (nnimap-find-minmax-uid mbx 'examine))) (when info - (insert (format "\"%s\" %d %d y\n" - mbx (or (nth 2 info) 0) - (max 1 (or (nth 1 info) 1))))))))) + (insert (format "\"%s\" %d %d y\n" + mbx (or (nth 2 info) 0) + (max 1 (or (nth 1 info) 1))))))))) (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s...done" (if (> (length server) 0) " on " "") server)) t)) - + (deffoo nnimap-request-create-group (group &optional server args) (when (nnimap-possibly-change-server server) (or (imap-mailbox-status group 'uidvalidity nnimap-server-buffer) @@ -955,10 +1200,12 @@ function is generally only called when Gnus is shutting down." (defun nnimap-date-days-ago (daysago) "Return date, in format \"3-Aug-1998\", for DAYSAGO days ago." - (let ((date (format-time-string "%d-%b-%Y" - (nnimap-time-substract - (current-time) - (days-to-time daysago))))) + (let* ((time (nnimap-time-substract (current-time) (days-to-time daysago))) + (date (format-time-string + (format "%%d-%s-%%Y" + (capitalize (car (rassoc (nth 4 (decode-time time)) + parse-time-months)))) + time))) (if (eq ?0 (string-to-char date)) (substring date 1) date))) @@ -967,32 +1214,51 @@ function is generally only called when Gnus is shutting down." (gnus-message 5 "nnimap: Marking article %d for deletion..." imap-current-message)) + +(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)) + ;; hints for optimization in `nnimap-request-accept-article' + (let ((nnimap-current-move-article art) + (nnimap-current-move-group group) + (nnimap-current-move-server server)) + (nnmail-expiry-target-group nnmail-expiry-target group)))) + ;; It is not clear if `nnmail-expiry-target' somehow cause the + ;; current group to be changed or not, so we make sure here. + (nnimap-possibly-change-group group server))) + ;; Notice that we don't actually delete anything, we just mark them deleted. (deffoo nnimap-request-expire-articles (articles group &optional server force) (let ((artseq (gnus-compress-sequence articles))) (when (and artseq (nnimap-possibly-change-group group server)) (with-current-buffer nnimap-server-buffer (if force - (and (imap-message-flags-add - (nnimap-range-to-string artseq) "\\Deleted") - (setq articles nil)) + (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) - (and (imap-message-flags-add - (nnimap-range-to-string artseq) "\\Deleted") - (setq articles nil))) + (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 "UID %s NOT SINCE %s" - (nnimap-range-to-string artseq) + (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))) + (nnimap-expiry-target oldarts group server) (and oldarts (imap-message-flags-add - (nnimap-range-to-string + (imap-range-to-message-set (gnus-compress-sequence oldarts)) "\\Deleted") (setq articles (gnus-set-difference @@ -1017,28 +1283,35 @@ function is generally only called when Gnus is shutting down." (setq result (eval accept-form)) (kill-buffer buf) result) - (nnimap-request-expire-articles (list article) group server t)) + (imap-message-flags-add + (imap-range-to-message-set (list article)) + "\\Deleted" 'silent nnimap-server-buffer)) result)))) - + (deffoo nnimap-request-accept-article (group &optional server last) (when (nnimap-possibly-change-server server) (let (uid) (if (setq uid (if (string= nnimap-current-server nnimap-current-move-server) - ;; moving article within same server, speed it up... + ;; moving article within same server, speed it up... (and (nnimap-possibly-change-group nnimap-current-move-group) (imap-message-copy (number-to-string nnimap-current-move-article) group 'dontcreate nil nnimap-server-buffer)) - ;; turn into rfc822 format (\r\n eol's) (with-current-buffer (current-buffer) (goto-char (point-min)) + ;; remove any 'From blabla' lines, some IMAP servers + ;; reject the entire message otherwise. + (when (looking-at "^From[^:]") + (kill-region (point) (progn (forward-line) (point)))) + ;; turn into rfc822 format (\r\n eol's) (while (search-forward "\n" nil t) (replace-match "\r\n"))) - ;; next line for Cyrus server bug - (imap-mailbox-unselect nnimap-server-buffer) + ;; this 'or' is for Cyrus server bug + (or (null (imap-current-mailbox nnimap-server-buffer)) + (imap-mailbox-unselect nnimap-server-buffer)) (imap-message-append group (current-buffer) nil nil nnimap-server-buffer))) (cons group (nth 1 uid)) @@ -1059,11 +1332,12 @@ function is generally only called when Gnus is shutting down." (defun nnimap-expunge (mailbox server) (when (nnimap-possibly-change-group mailbox server) - (imap-mailbox-expunge nnimap-server-buffer))) + (imap-mailbox-expunge nil nnimap-server-buffer))) (defun nnimap-acl-get (mailbox server) (when (nnimap-possibly-change-server server) - (imap-mailbox-acl-get mailbox nnimap-server-buffer))) + (and (imap-capability 'ACL nnimap-server-buffer) + (imap-mailbox-acl-get mailbox nnimap-server-buffer)))) (defun nnimap-acl-edit (mailbox method old-acls new-acls) (when (nnimap-possibly-change-server (cadr method)) @@ -1106,12 +1380,13 @@ function is generally only called when Gnus is shutting down." (mapcar (lambda (pair) ; cdr is the mark (or (assoc (cdr pair) - '((read . "SEEN") - (tick . "FLAGGED") - (draft . "DRAFT") - (reply . "ANSWERED"))) - (cons (cdr pair) - (format "KEYWORD gnus-%s" (symbol-name (cdr pair)))))) + '((read . "SEEN") + (tick . "FLAGGED") + (draft . "DRAFT") + (recent . "RECENT") + (reply . "ANSWERED"))) + (cons (cdr pair) + (format "KEYWORD gnus-%s" (symbol-name (cdr pair)))))) (cons '(read . read) gnus-article-mark-lists))) (defun nnimap-mark-to-predicate (pred) @@ -1124,12 +1399,13 @@ to be used within a IMAP SEARCH query." (mapcar (lambda (pair) (or (assoc (cdr pair) - '((read . "\\Seen") - (tick . "\\Flagged") - (draft . "\\Draft") - (reply . "\\Answered"))) - (cons (cdr pair) - (format "gnus-%s" (symbol-name (cdr pair)))))) + '((read . "\\Seen") + (tick . "\\Flagged") + (draft . "\\Draft") + (recent . "\\Recent") + (reply . "\\Answered"))) + (cons (cdr pair) + (format "gnus-%s" (symbol-name (cdr pair)))))) (cons '(read . read) gnus-article-mark-lists))) (defun nnimap-mark-to-flag-1 (preds) @@ -1159,98 +1435,67 @@ be used in a STORE FLAGS command." "Return t iff MARK can be permanently (between IMAP sessions) saved on articles, in GROUP." (imap-message-flag-permanent-p (nnimap-mark-to-flag mark))) -(defun nnimap-remassoc (key alist) - "Delete by side effect any elements of LIST whose car is `equal' to KEY. -The modified LIST is returned. If the first member -of LIST has a car that is `equal' to KEY, there is no way to remove it -by side effect; therefore, write `(setq foo (remassoc key foo))' to be -sure of changing the value of `foo'." - (when alist - (if (equal key (caar alist)) - (cdr alist) - (setcdr alist (nnimap-remassoc key (cdr alist))) - alist))) - -(defun nnimap-update-alist-soft (key value alist) - (if value - (cons (cons key value) (nnimap-remassoc key alist)) - (nnimap-remassoc key alist))) - -(defun nnimap-range-to-string (range) - (mapconcat - (lambda (item) - (if (consp item) - (format "%d:%d" - (car item) (cdr item)) - (format "%d" item))) - (if (and (listp range) (not (listp (cdr range)))) - (list range);; make (1 . 2) into ((1 . 2)) - range) - ",")) - (when nnimap-debug (require 'trace) (buffer-disable-undo (get-buffer-create nnimap-debug)) (mapcar (lambda (f) (trace-function-background f nnimap-debug)) - '( - nnimap-possibly-change-server - nnimap-verify-uidvalidity - nnimap-find-minmax-uid - nnimap-possibly-change-group - ;;nnimap-replace-whitespace - nnimap-retrieve-headers-progress - nnimap-retrieve-which-headers - nnimap-group-overview-filename - nnimap-retrieve-headers-from-file - nnimap-retrieve-headers-from-server - nnimap-retrieve-headers - nnimap-open-connection - nnimap-open-server - nnimap-server-opened - nnimap-close-server - nnimap-request-close - nnimap-status-message - ;;nnimap-demule - nnimap-request-article-part - nnimap-request-article - nnimap-request-head - nnimap-request-body - nnimap-request-group - nnimap-close-group - nnimap-pattern-to-list-arguments - nnimap-request-list - nnimap-request-post - nnimap-retrieve-groups - nnimap-request-update-info-internal - nnimap-request-type - nnimap-request-set-mark - nnimap-split-to-groups - nnimap-split-find-rule - nnimap-split-find-inbox - nnimap-split-articles - nnimap-request-scan - nnimap-request-newgroups - nnimap-request-create-group - nnimap-time-substract - nnimap-date-days-ago - nnimap-request-expire-articles-progress - nnimap-request-expire-articles - nnimap-request-move-article - nnimap-request-accept-article - nnimap-request-delete-group - nnimap-request-rename-group - gnus-group-nnimap-expunge - gnus-group-nnimap-edit-acl - gnus-group-nnimap-edit-acl-done - nnimap-group-mode-hook - nnimap-mark-to-predicate - nnimap-mark-to-flag-1 - nnimap-mark-to-flag - nnimap-mark-permanent-p - nnimap-remassoc - nnimap-update-alist-soft - nnimap-range-to-string - ))) + '( + nnimap-possibly-change-server + nnimap-verify-uidvalidity + nnimap-find-minmax-uid + nnimap-before-find-minmax-bugworkaround + nnimap-possibly-change-group + ;;nnimap-replace-whitespace + nnimap-retrieve-headers-progress + nnimap-retrieve-which-headers + nnimap-group-overview-filename + nnimap-retrieve-headers-from-file + nnimap-retrieve-headers-from-server + nnimap-retrieve-headers + nnimap-open-connection + nnimap-open-server + nnimap-server-opened + nnimap-close-server + nnimap-request-close + nnimap-status-message + ;;nnimap-demule + nnimap-request-article-part + nnimap-request-article + nnimap-request-head + nnimap-request-body + nnimap-request-group + nnimap-close-group + nnimap-pattern-to-list-arguments + nnimap-request-list + nnimap-request-post + nnimap-retrieve-groups + nnimap-request-update-info-internal + nnimap-request-type + nnimap-request-set-mark + nnimap-split-to-groups + nnimap-split-find-rule + nnimap-split-find-inbox + nnimap-split-articles + nnimap-request-scan + nnimap-request-newgroups + nnimap-request-create-group + nnimap-time-substract + nnimap-date-days-ago + nnimap-request-expire-articles-progress + nnimap-request-expire-articles + nnimap-request-move-article + nnimap-request-accept-article + nnimap-request-delete-group + nnimap-request-rename-group + gnus-group-nnimap-expunge + gnus-group-nnimap-edit-acl + gnus-group-nnimap-edit-acl-done + nnimap-group-mode-hook + nnimap-mark-to-predicate + nnimap-mark-to-flag-1 + nnimap-mark-to-flag + nnimap-mark-permanent-p + ))) (provide 'nnimap)