X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fnnimap.el;h=5e9b62e7014817fa403504b67aba9900cc119564;hb=8d19d878d63af88690d21861d61e566d905fc96a;hp=75814790c329480fef719a643e21e06338951f75;hpb=027a90912122f2cb3e36d82310f32962e3ce2f71;p=elisp%2Fgnus.git- diff --git a/lisp/nnimap.el b/lisp/nnimap.el index 7581479..5e9b62e 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 @@ -58,13 +57,13 @@ ;;; Code: -(eval-and-compile - (require 'imap)) +(eval-when-compile (require 'cl)) +(eval-when-compile (require 'gnus-clfns)) +(eval-and-compile (require 'imap)) (require 'nnoo) (require 'nnmail) (require 'nnheader) -(require 'mm-util) (require 'gnus) (require 'gnus-range) (require 'gnus-start) @@ -113,10 +112,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,7 +119,32 @@ 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.") +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.") + +(defvar 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.") (defvar nnimap-split-fancy nil "Like `nnmail-split-fancy', which see.") @@ -261,7 +281,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) @@ -308,6 +330,14 @@ If SERVER is nil, uses the current server." (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'." + ;; 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." @@ -361,9 +391,10 @@ 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 + mbx imap-current-mailbox headers (if (imap-capability 'IMAP4rev1) ;; xxx don't just use car? alist doesn't contain ;; anything else now, but it might... @@ -375,11 +406,17 @@ If EXAMINE is non-nil the group is selected read-only." (with-temp-buffer (buffer-disable-undo) (insert headers) + (nnheader-fold-continuation-lines) + (subst-char-in-region (point-min) (point-max) ?\t ? ) (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 +425,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 @@ -413,7 +450,7 @@ If EXAMINE is non-nil the group is selected read-only." (if (or nnmail-use-long-file-names (file-exists-p (concat dir file))) (concat dir file) - (concat dir (mm-encode-coding-string + (concat dir (encode-coding-string (nnheader-replace-chars-in-string file ?. ?/) nnmail-pathname-coding-system))))) @@ -421,7 +458,7 @@ If EXAMINE is non-nil the group is selected read-only." (with-current-buffer nntp-server-buffer (let ((nov (nnimap-group-overview-filename group server))) (when (file-exists-p nov) - (mm-insert-file-contents nov) + (nnheader-insert-file-contents nov) (set-buffer-modified-p nil) (let ((min (progn (goto-char (point-min)) (when (not (eobp)) @@ -441,7 +478,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 @@ -492,8 +529,8 @@ If EXAMINE is non-nil the group is selected read-only." ;; 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) - (gnus-delete-line))))) + (when (re-search-forward (format "^%d\t" uid) nil t) + (gnus-delete-line))))) ;; nothing cached, fetch whole range from server (nnimap-retrieve-headers-from-server (cons low high) group server)) @@ -512,15 +549,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) @@ -598,12 +635,16 @@ 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 + (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 @@ -611,19 +652,22 @@ function is generally only called when Gnus is shutting down." 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))) - (nnheader-ms-strip-cr) - (gnus-message 9 "nnimap: Fetching (part of) article %d...done" - article) - (if (bobp) - (nnheader-report 'nnimap "No such article: %s" - (imap-error-text nnimap-server-buffer)) - (cons group article))) + (let ((data (imap-fetch article part prop nil + nnimap-server-buffer))) + (when data + (insert (if detail (nth 2 (car data)) data)) + (nnheader-ms-strip-cr) + (gnus-message 10 + "nnimap: Fetching (part of) article %d...done" + article) + (if (bobp) + (nnheader-report 'nnimap "No such article: %s" + (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) @@ -634,16 +678,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 +705,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))) @@ -695,6 +749,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 @@ -712,8 +767,9 @@ function is generally only called when Gnus is shutting down." (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,6 +791,7 @@ 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" @@ -823,15 +880,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) @@ -871,8 +928,21 @@ function is generally only called when Gnus is shutting down." (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) @@ -889,7 +959,7 @@ function is generally only called when Gnus is shutting down." ;; 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) @@ -923,19 +993,22 @@ 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 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)) @@ -974,25 +1047,25 @@ function is generally only called when Gnus is shutting down." (with-current-buffer nnimap-server-buffer (if force (and (imap-message-flags-add - (nnimap-range-to-string artseq) "\\Deleted") + (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") + (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) + (imap-range-to-message-set artseq) (nnimap-date-days-ago days)))) (imap-fetch-data-hook '(nnimap-request-expire-articles-progress))) (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 @@ -1037,8 +1110,9 @@ function is generally only called when Gnus is shutting down." (goto-char (point-min)) (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)) @@ -1176,18 +1250,6 @@ sure of changing the value of `foo'." (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)) @@ -1196,6 +1258,7 @@ sure of changing the value of `foo'." 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 @@ -1249,7 +1312,6 @@ sure of changing the value of `foo'." nnimap-mark-permanent-p nnimap-remassoc nnimap-update-alist-soft - nnimap-range-to-string ))) (provide 'nnimap)