diff options
Diffstat (limited to 'lisp/gnus/nnimap.el')
| -rw-r--r-- | lisp/gnus/nnimap.el | 2651 |
1 files changed, 900 insertions, 1751 deletions
diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index d412af46d0c..e7bf0f376a8 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -1,11 +1,9 @@ -;;; nnimap.el --- imap backend for Gnus +;;; nnimap.el --- IMAP interface for Gnus -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, -;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010 Free Software Foundation, Inc. -;; Author: Simon Josefsson <simon@josefsson.org> -;; Jim Radford <radford@robby.caltech.edu> -;; Keywords: mail +;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> +;; Simon Josefsson <simon@josefsson.org> ;; This file is part of GNU Emacs. @@ -24,1791 +22,942 @@ ;;; Commentary: -;; Todo, major things: -;; -;; o Fix Gnus to view correct number of unread/total articles in group buffer -;; o Fix Gnus to handle leading '.' in group names (fixed?) -;; o Finish disconnected mode (moving articles between mailboxes unplugged) -;; o Sieve -;; o MIME (partial article fetches) -;; o Split to other backends, different split rules for different -;; servers/inboxes -;; -;; Todo, minor things: -;; -;; o Don't require half of Gnus -- backends should be standalone -;; 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 -;; o What do I do with gnus-newsgroup-*? -;; o Tell Gnus about new groups (how can we tell?) -;; o Respooling (fix Gnus?) (unnecessary?) -;; o Add support for the following: (if applicable) -;; request-list-newsgroups, request-regenerate -;; list-active-group, -;; request-associate-buffer, request-restore-buffer, -;; o Do The Right Thing when UIDVALIDITY changes (what's the right thing?) -;; o Support RFC2221 (Login referrals) -;; o IMAP2BIS compatibility? (RFC2061) -;; o ACAP stuff (perhaps a different project, would be nice to ACAPify -;; .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 -;; o Rewrite UID SEARCH UID X as UID FETCH X (UID) for those with slow servers +;; nnimap interfaces Gnus with IMAP servers. ;;; Code: -;; For Emacs < 22.2. (eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + (require 'nnheader)) -(require 'imap) -(require 'nnoo) -(require 'nnmail) -(require 'nnheader) -(require 'mm-util) -(require 'gnus) -(require 'gnus-range) -(require 'gnus-start) -(require 'gnus-int) +(eval-when-compile + (require 'cl)) -(eval-when-compile (require 'cl)) - -(autoload 'auth-source-user-or-password "auth-source") +(require 'netrc) (nnoo-declare nnimap) -(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.") + "The address of the IMAP server.") (defvoo nnimap-server-port nil - "Port number on physical IMAP server. -If nil, defaults to 993 for TLS/SSL connections and 143 otherwise.") - -;; Splitting variables - -(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." - :group 'nnimap - :type 'boolean) - -(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-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) - -(defun nnimap-strict-function-match (widget value) - "Ignoring WIDGET, match if VALUE is a function." - (functionp value)) - -(defcustom nnimap-split-rule nil - "Mail will be split according to these rules. - -Mail is read from mailbox(es) specified in `nnimap-split-inbox'. - -If you'd like, for instance, one mail group for mail from the -\"gnus-imap\" mailing list, one group for junk mail and leave -everything else in the incoming mailbox, you could do something like -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 (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 -the argument. It should return a non-nil value if it thinks that the -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. 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 - ;; FIXME: Doesn't allow `("my2server" ("INBOX" nnimap-split-fancy))' - ;; per example above. -- fx - :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 the variable `nnmail-split-fancy'." - :group 'nnimap - :type 'sexp) + "The IMAP port used. +If nnimap-stream is `ssl', this will default to `imaps'. If not, +it will default to `imap'.") + +(defvoo nnimap-stream 'ssl + "How nnimap will talk to the IMAP server. +Values are `ssl' and `network'.") + +(defvoo nnimap-shell-program (if (boundp 'imap-shell-program) + (if (listp imap-shell-program) + (car imap-shell-program) + imap-shell-program) + "ssh %s imapd")) + +(defvoo nnimap-inbox nil + "The mail box where incoming mail arrives and should be split out of.") + +(defvoo nnimap-expunge-inbox nil + "If non-nil, expunge the inbox after fetching mail. +This is always done if the server supports UID EXPUNGE, but it's +not done by default on servers that doesn't support that command.") + +(defvoo nnimap-connection-alist nil) +(defvar nnimap-process nil) + +(defvar nnimap-status-string "") (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 -analyzes 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 behavior 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." - :version "22.1" - :group 'nnimap - :type '(choice (const :tag "Let system decide" deault) - boolean)) - -;; Performance / bug workaround variables - -(defcustom nnimap-close-asynchronous t - "Close mailboxes asynchronously in `nnimap-close-group'. -This means that errors caught by nnimap when closing the mailbox will -not prevent Gnus from updating the group status, which may be harmful. -However, it increases speed." - :version "22.1" - :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." - :version "22.1" - :type 'boolean - :group 'nnimap) - -(defcustom nnimap-retrieve-groups-asynchronous t - "Send asynchronous STATUS commands for each mailbox before checking mail. -If you have mailboxes that rarely receives mail, this speeds up new -mail checking. It works by first sending STATUS commands for each -mailbox, and then only checking groups which has a modified UIDNEXT -more carefully for new mail. - -In summary, the default is O((1-p)*k+p*n) and changing it to nil makes -it O(n). If p is small, then the default is probably faster." - :version "22.1" - :type 'boolean - :group 'nnimap) - -(defvoo nnimap-need-unselect-to-notice-new-mail t - "Unselect mailboxes before looking for new mail in them. -Some servers seem to need this under some circumstances.") - -(defvoo nnimap-logout-timeout nil - "Close server immediately if it can't logout in this number of seconds. -If it is nil, never close server until logout completes. This variable -overrides `imap-logout-timeout' on a per-server basis.") - -;; Authorization / Privacy variables - -(defvoo nnimap-auth-method nil - "Obsolete.") - -(defvoo nnimap-stream nil - "How nnimap will connect to the server. - -The default, nil, will try to use the \"best\" method the server can -handle. - -Change this if - -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: 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. - -The default, nil, will try to use the \"best\" method the server can -handle. - -There is only one reason for fiddling with this variable, and that is -if your server is more capable than your environment -- i.e. you -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: 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. -See also `nnimap-nov-file-name'.") - -(defvoo nnimap-nov-file-name "nnimap." - "NOV cache base filename. -The group name and `nnimap-nov-file-name-suffix' will be appended. A -typical complete file name would be -~/News/overview/nnimap.pdc.INBOX.ding.nov, or -~/News/overview/nnimap/pdc/INBOX/ding/nov if -`nnmail-use-long-file-names' is nil") - -(defvoo nnimap-nov-file-name-suffix ".novcache" - "Suffix for NOV cache base filename.") - -(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.") - -(defvoo nnimap-search-uids-not-since-is-evil nil - "If non-nil, avoid \"UID SEARCH UID ... NOT SINCE\" queries when expiring. -Instead, use \"UID SEARCH SINCE\" to prune the list of expirable -articles within Gnus. This seems to be faster on Courier in some cases.") - -(defvoo nnimap-expunge-on-close 'always ; 'ask, 'never - "Whether to expunge a group when it is closed. -When a IMAP group with articles marked for deletion is closed, this -variable determine if nnimap should actually remove the articles or -not. - -If always, nnimap always perform a expunge when closing the group. -If never, nnimap never expunges articles marked for deletion. -If ask, nnimap will ask you if you wish to expunge marked articles. - -When setting this variable to `never', you can only expunge articles -by using `G x' (gnus-group-nnimap-expunge) from the Group buffer.") - -(defvoo nnimap-list-pattern "*" - "A string LIMIT or list of strings with mailbox wildcards used to limit available groups. -See below for available wildcards. - -The LIMIT string can be a cons cell (REFERENCE . LIMIT), where -REFERENCE will be passed as the first parameter to LIST/LSUB. The -semantics of this are server specific, on the University of Washington -server you can specify a directory. - -Example: - '(\"INBOX\" \"mail/*\" (\"~friend/mail/\" . \"list/*\")) - -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. - -This variable should contain a regexp matching groups where you wish -replies to be stored to the mailbox directly. - -Example: - '(\"^[^I][^N][^B][^O][^X].*$\") - -This will match all groups not beginning with \"INBOX\". - -Note that there is nothing technically different between mail-like and -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. - -However, if `nnimap-search-uids-not-since-is-evil' is true, this -variable has no effect since the search logic is reversed.") - -(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'.") - -(defcustom nnimap-authinfo-file "~/.authinfo" - "Authorization information for IMAP servers. In .netrc format." - :type - '(choice file - (repeat :tag "Entries" - :menu-tag "Inline" - (list :format "%v" - :value ("" ("login" . "") ("password" . "")) - (string :tag "Host") - (checklist :inline t - (cons :format "%v" - (const :format "" "login") - (string :format "Login: %v")) - (cons :format "%v" - (const :format "" "password") - (string :format "Password: %v")))))) - :group 'nnimap) - -(defcustom nnimap-prune-cache t - "If non-nil, nnimap check whether articles still exist on server before using data stored in NOV cache." - :type 'boolean - :group 'nnimap) - -(defvar nnimap-request-list-method 'imap-mailbox-list - "Method to use to request a list of all folders from the server. -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. -A nil value means no information is sent, symbol `no' to disable ID query -altogether, 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, trace nnimap- functions into `nnimap-debug-buffer'. -Uses `trace-function-background', so you can turn it off with, -say, `untrace-all'. - -Note that username, passwords and other privacy sensitive -information (such as e-mail) may be stored in the buffer. -It is not written to disk, however. Do not enable this -variable unless you are comfortable with that. - -This variable only takes effect when loading the `nnimap' library. -See also `nnimap-log'." - :group 'nnimap - :type 'boolean) - -;; Internal variables: - -(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) -(defvar nnimap-length) -(defvar nnimap-progress-chars '(?| ?/ ?- ?\\)) -(defvar nnimap-progress-how-often 20) -(defvar nnimap-counter) -(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 - - - -(nnoo-define-basics nnimap) - -;; Utility functions: - -(defsubst nnimap-decode-group-name (group) - (and group - (gnus-group-decoded-name group))) - -(defsubst nnimap-encode-group-name (group) - (and group - (mm-encode-coding-string group (gnus-group-name-charset nil group)))) - -(defun nnimap-group-prefixed-name (group &optional server) - (gnus-group-prefixed-name group - (gnus-server-to-method - (format "nnimap:%s" - (or server nnimap-current-server))))) - -(defsubst nnimap-get-server-buffer (server) - "Return buffer for SERVER, if nil use current server." - (cadr (assoc (or server nnimap-current-server) nnimap-server-buffer-alist))) - -(defun nnimap-remove-server-from-buffer-alist (server list) - "Remove SERVER from LIST." - (let (l) - (dolist (e list) - (unless (equal server (car-safe e)) - (push e l))) - l)) - -(defun nnimap-possibly-change-server (server) - "Return buffer for SERVER, changing the current server as a side-effect. -If SERVER is nil, uses the current server." - (setq nnimap-current-server (or server nnimap-current-server) - nnimap-server-buffer (nnimap-get-server-buffer nnimap-current-server))) - -(defun nnimap-verify-uidvalidity (group server) - "Verify stored uidvalidity match current one in GROUP on SERVER." - (let* ((gnusgroup (nnimap-group-prefixed-name group server)) - (new-uidvalidity (imap-mailbox-get '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)) - ;; uidvalidity clash - (progn - (gnus-group-set-parameter gnusgroup 'uidvalidity new-uidvalidity) - (gnus-group-remove-parameter gnusgroup 'imap-status) - (gnus-sethash (gnus-group-prefixed-name group server) - nil nnimap-mailbox-info) - (gnus-delete-file file)) - t) - (gnus-group-add-parameter gnusgroup (cons 'uidvalidity new-uidvalidity)) - (gnus-group-remove-parameter gnusgroup 'imap-status) - (gnus-sethash ; Maybe not necessary here. - (gnus-group-prefixed-name group server) - nil nnimap-mailbox-info) - t))) +(defstruct nnimap + group process commands capabilities) -(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 number in GROUP. -If EXAMINE is non-nil the group is selected read-only." - (with-current-buffer nnimap-server-buffer - (let ((decoded-group (nnimap-decode-group-name group))) - (when (or (string= decoded-group (imap-current-mailbox)) - (imap-mailbox-select decoded-group examine)) - (let (minuid maxuid) - (when (> (imap-mailbox-get 'exists) 0) - (imap-fetch "1:*" "UID" nil 'nouidfetch) - (imap-message-map - (lambda (uid Uid) - (setq minuid (if minuid (min minuid uid) uid) - 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) - (let ((decoded-group (nnimap-decode-group-name group))) - (with-current-buffer nnimap-server-buffer - (if (or (null group) (imap-current-mailbox-p decoded-group)) - imap-current-mailbox ; Note: utf-7 encoded. - (if (imap-mailbox-select decoded-group) - (if (or (nnimap-verify-uidvalidity - group (or server nnimap-current-server)) - (zerop (imap-mailbox-get 'exists decoded-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? " - decoded-group))) - imap-current-mailbox ; Note: utf-7 encoded. - (imap-mailbox-unselect) - (error "nnimap: Group %s is not uid-valid" decoded-group)) - (nnheader-report 'nnimap (imap-error-text)))))))) - -(defun nnimap-replace-whitespace (string) - "Return STRING with all whitespace replaced with space." - (when string - (while (string-match "[\r\n\t]+" string) - (setq string (replace-match " " t t string))) - string)) - -;; Required backend functions - -(defun nnimap-retrieve-headers-progress () - "Hook to insert NOV line for current article into `nntp-server-buffer'." - (and (numberp nnmail-large-newsgroup) - (zerop (% (incf nnimap-counter) nnimap-progress-how-often)) - (> nnimap-length nnmail-large-newsgroup) - (nnheader-message 6 "nnimap: Retrieving headers... %c" - (nth (/ (% nnimap-counter - (* (length nnimap-progress-chars) - nnimap-progress-how-often)) - nnimap-progress-how-often) - nnimap-progress-chars))) - (with-current-buffer nntp-server-buffer - (let (headers lines chars uid mbx) - (with-current-buffer nnimap-server-buffer - (setq uid imap-current-message - mbx (nnimap-encode-group-name (imap-current-mailbox)) - 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)) - lines (imap-body-lines (imap-message-body imap-current-message)) - chars (imap-message-get imap-current-message 'RFC822.SIZE))) - (nnheader-insert-nov - ;; At this stage, we only have bytes, so let's use unibyte buffers - ;; to make it more clear. - (mm-with-unibyte-buffer - (buffer-disable-undo) - ;; headers can be nil if article is write-only - (when headers (insert headers)) - (let ((head (nnheader-parse-naked-head uid))) - (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) - "Get a range of articles to fetch based on ARTICLES and FETCH-OLD." - (with-current-buffer nnimap-server-buffer - (if (numberp (car-safe articles)) - (imap-search - (concat "UID " - (imap-range-to-message-set - (gnus-compress-sequence - (append (gnus-uncompress-sequence - (and fetch-old - (cons (if (numberp fetch-old) - (max 1 (- (car articles) fetch-old)) - 1) - (1- (car articles))))) - articles))))) - (mapcar (lambda (msgid) - (imap-search - (format "HEADER Message-Id \"%s\"" msgid))) - articles)))) - -(defun nnimap-group-overview-filename (group server) - "Make file name for GROUP on SERVER." - (let* ((dir (file-name-as-directory (expand-file-name nnimap-directory))) - (uidvalidity (gnus-group-get-parameter - (nnimap-group-prefixed-name group 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) +(defvar nnimap-object nil) + +(defvar nnimap-mark-alist + '((read "\\Seen") + (tick "\\Flagged") + (reply "\\Answered") + (expire "gnus-expire") + (dormant "gnus-dormant") + (score "gnus-score") + (save "gnus-save") + (download "gnus-download") + (forward "gnus-forward"))) + +(defvar nnimap-split-methods nil) + +(defun nnimap-buffer () + (nnimap-find-process-buffer nntp-server-buffer)) + +(defun nnimap-retrieve-headers (articles &optional group server fetch-old) (with-current-buffer nntp-server-buffer - (let ((nov (nnimap-group-overview-filename group server))) - (when (file-exists-p nov) - (mm-insert-file-contents nov) - (set-buffer-modified-p nil) - (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 - (erase-buffer) - nil)))))) - -(defun nnimap-retrieve-headers-from-server (articles group server) - (with-current-buffer nnimap-server-buffer - (let ((imap-fetch-data-hook '(nnimap-retrieve-headers-progress)) - (nnimap-length (gnus-range-length articles)) - (nnimap-counter 0)) - (imap-fetch (imap-range-to-message-set articles) - (concat "(UID RFC822.SIZE BODY " - (let ((headers - (append '(Subject From Date Message-Id - References In-Reply-To Xref) - (copy-sequence - nnmail-extra-headers)))) - (if (imap-capability 'IMAP4rev1) - (format "BODY.PEEK[HEADER.FIELDS %s])" headers) - (format "RFC822.HEADER.LINES %s)" headers))))) - (with-current-buffer nntp-server-buffer - (sort-numeric-fields 1 (point-min) (point-max))) - (and (numberp nnmail-large-newsgroup) - (> nnimap-length nnmail-large-newsgroup) - (nnheader-message 6 "nnimap: Retrieving headers...done"))))) - -(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 - (nnimap-group-overview-filename group server))) - (file-writable-p - (nnimap-group-overview-filename group server))) - (message "nnimap: Nov cache not writable, %s" - (nnimap-group-overview-filename group server))))) - -(deffoo nnimap-retrieve-headers (articles &optional group server fetch-old) - (when (nnimap-possibly-change-group group server) - (with-current-buffer nntp-server-buffer - (erase-buffer) - (if (nnimap-dont-use-nov-p group server) - (nnimap-retrieve-headers-from-server - (gnus-compress-sequence articles) group server) - (let (uids cached low high) - (when (setq uids (nnimap-retrieve-which-headers articles fetch-old) - low (car uids) - high (car (last uids))) - (if (setq cached (nnimap-retrieve-headers-from-file group server)) - (progn - ;; fetch articles with uids before cache block - (when (< low (car cached)) - (goto-char (point-min)) - (nnimap-retrieve-headers-from-server - (cons low (1- (car cached))) group server)) - ;; fetch articles with uids after cache block - (when (> high (cdr cached)) - (goto-char (point-max)) - (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 - (goto-char (point-min)) - (dolist (uid (gnus-set-difference articles uids)) - (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)) - (when (buffer-modified-p) - (nnmail-write-region - (point-min) (point-max) - (nnimap-group-overview-filename group server) nil 'nomesg)) - (nnheader-nov-delete-outside-range low high)))) - 'nov))) - -(declare-function netrc-parse "netrc" (file)) -(declare-function netrc-machine-user-or-password "netrc" - (mode authinfo-file-or-list machines ports defaults)) - -(defun nnimap-open-connection (server) - ;; Note: `nnimap-open-server' that calls this function binds - ;; `imap-logout-timeout' to `nnimap-logout-timeout'. - (if (not (imap-open nnimap-address nnimap-server-port nnimap-stream - nnimap-authenticator nnimap-server-buffer)) - (nnheader-report 'nnimap "Can't open connection to server %s" server) - (require 'netrc) - (unless (or (imap-capability 'IMAP4 nnimap-server-buffer) - (imap-capability 'IMAP4rev1 nnimap-server-buffer)) - (imap-close nnimap-server-buffer) - (nnheader-report 'nnimap "Server %s is not IMAP4 compliant" server)) - (let* ((list (progn (gnus-message 7 "Parsing authinfo file `%s'." - nnimap-authinfo-file) - (netrc-parse nnimap-authinfo-file))) - (port (if nnimap-server-port - (int-to-string nnimap-server-port) - "imap")) - (auth-info - (auth-source-user-or-password '("login" "password") server port)) - (auth-user (nth 0 auth-info)) - (auth-passwd (nth 1 auth-info)) - (user (or - auth-user ; this is preferred to netrc-* - (netrc-machine-user-or-password - "login" - list - (list server - (or nnimap-server-address - nnimap-address)) - (list port) - (list "imap" "imaps" "143" "993")))) - (passwd (or - auth-passwd ; this is preferred to netrc-* - (netrc-machine-user-or-password - "password" - list - (list server - (or nnimap-server-address - nnimap-address)) - (list port) - (list "imap" "imaps" "143" "993"))))) - (if (imap-authenticate user passwd nnimap-server-buffer) - (prog2 - (setq nnimap-server-buffer-alist - (nnimap-remove-server-from-buffer-alist - server - nnimap-server-buffer-alist)) - (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) - (nnheader-report 'nnimap "Could not authenticate to %s" server))))) - -(deffoo nnimap-open-server (server &optional defs) - (nnheader-init-server-buffer) + (erase-buffer) + (when (nnimap-possibly-change-group group server) + (with-current-buffer (nnimap-buffer) + (nnimap-send-command "SELECT %S" (utf7-encode group t)) + (erase-buffer) + (nnimap-wait-for-response + (nnimap-send-command + "UID FETCH %s %s" + (nnimap-article-ranges (gnus-compress-sequence articles)) + (format "(UID RFC822.SIZE BODYSTRUCTURE %s)" + (format + (if (member "IMAP4REV1" + (nnimap-capabilities nnimap-object)) + "BODY.PEEK[HEADER.FIELDS %s]" + "RFC822.HEADER.LINES %s") + (append '(Subject From Date Message-Id + References In-Reply-To Xref) + nnmail-extra-headers)))) + t) + (nnimap-transform-headers)) + (insert-buffer-substring + (nnimap-find-process-buffer (current-buffer)))) + t)) + +(defun nnimap-transform-headers () + (goto-char (point-min)) + (let (article bytes lines) + (block nil + (while (not (eobp)) + (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)")) + (delete-region (point) (progn (forward-line 1) (point))) + (when (eobp) + (return))) + (setq article (match-string 1) + bytes (nnimap-get-length) + lines nil) + (beginning-of-line) + (when (search-forward "BODYSTRUCTURE" (line-end-position) t) + (let ((structure (ignore-errors (read (current-buffer))))) + (while (and (consp structure) + (not (stringp (car structure)))) + (setq structure (car structure))) + (setq lines (nth 7 structure)))) + (delete-region (line-beginning-position) (line-end-position)) + (insert (format "211 %s Article retrieved." article)) + (forward-line 1) + (insert (format "Bytes: %d\n" bytes)) + (when lines + (insert (format "Lines: %s\n" lines))) + (re-search-forward "^\r$") + (delete-region (line-beginning-position) (line-end-position)) + (insert ".") + (forward-line 1))))) + +(defun nnimap-get-length () + (and (re-search-forward "{\\([0-9]+\\)}" (line-end-position) t) + (string-to-number (match-string 1)))) + +(defun nnimap-article-ranges (ranges) + (let (result) + (cond + ((numberp ranges) + (number-to-string ranges)) + ((numberp (cdr ranges)) + (format "%d:%d" (car ranges) (cdr ranges))) + (t + (dolist (elem ranges) + (push + (if (consp elem) + (format "%d:%d" (car elem) (cdr elem)) + (number-to-string elem)) + result)) + (mapconcat #'identity (nreverse result) ","))))) + +(defun nnimap-open-server (server &optional defs) (if (nnimap-server-opened server) t - (unless (assq 'nnimap-server-buffer defs) - (push (list 'nnimap-server-buffer (concat " *nnimap* " server)) defs)) - ;; translate `nnimap-server-address' to `nnimap-address' in defs - ;; for people that configured nnimap with a very old version (unless (assq 'nnimap-address defs) - (if (assq 'nnimap-server-address defs) - (push (list 'nnimap-address - (cadr (assq 'nnimap-server-address defs))) defs) - (push (list 'nnimap-address server) defs))) + (setq defs (append defs (list (list 'nnimap-address server))))) (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)) - (let ((imap-logout-timeout nnimap-logout-timeout)) - (or (and nnimap-server-buffer - (imap-opened nnimap-server-buffer) - (if (with-current-buffer nnimap-server-buffer - (memq imap-state '(auth selected examine))) - t - (imap-close nnimap-server-buffer) - (nnimap-open-connection server))) - (nnimap-open-connection server))))) - -(deffoo nnimap-server-opened (&optional server) - "Whether SERVER is opened. -If SERVER is the current virtual server, and the connection to the -physical server is alive, this function return a non-nil value. If -SERVER is nil, it is treated as the current server." - ;; clean up autologouts?? - (and (or server nnimap-current-server) - (nnoo-server-opened 'nnimap (or server nnimap-current-server)) - (imap-opened (nnimap-get-server-buffer server)))) - -(deffoo nnimap-close-server (&optional server) - "Close connection to server and free all resources connected to it. -Return nil if the server couldn't be closed for some reason." - (let ((server (or server nnimap-current-server)) - (imap-logout-timeout nnimap-logout-timeout)) - (when (or (nnimap-server-opened server) - (imap-opened (nnimap-get-server-buffer server))) - (imap-close (nnimap-get-server-buffer server)) - (kill-buffer (nnimap-get-server-buffer server)) - (setq nnimap-server-buffer nil - nnimap-current-server nil - nnimap-server-buffer-alist - (nnimap-remove-server-from-buffer-alist - server - nnimap-server-buffer-alist))) - (nnoo-close-server 'nnimap server))) - -(deffoo nnimap-request-close () - "Close connection to all servers and free all resources that the backend have reserved. -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." - (mapc (lambda (server) (nnimap-close-server (car server))) - nnimap-server-buffer-alist) - (setq nnimap-server-buffer-alist nil)) - -(deffoo nnimap-status-message (&optional server) - "This function returns the last error message from server." - (when (nnimap-possibly-change-server server) - (nnoo-status-message 'nnimap server))) - -;; We used to use a string-as-multibyte here, but it is really incorrect. -;; This function is used when we're about to insert a unibyte string -;; into a potentially multibyte buffer. The string is either an article -;; header or body (or both?), undecoded. When Emacs is asked to convert -;; a unibyte string to multibyte, it may either use the equivalent of -;; nothing (e.g. non-Mule XEmacs), string-make-unibyte (i.e. decode using -;; locale), string-as-multibyte (decode using emacs-internal coding system) -;; or string-to-multibyte (keep the data undecoded as a sequence of bytes). -;; Only the last one preserves the data such that we can reliably later on -;; decode the text using the mime info. -(defalias 'nnimap-demule 'mm-string-to-multibyte) - -(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) - (when (nnimap-possibly-change-group group server) - (let ((article (if (stringp article) - (car-safe (imap-search - (format "HEADER Message-Id \"%s\"" article) - nnimap-server-buffer)) - article))) - (when article - (gnus-message 10 "nnimap: Fetching (part of) article %d from %s..." - article (or (nnimap-decode-group-name group) - (imap-current-mailbox) - (nnimap-decode-group-name - gnus-newsgroup-name))) - (if (not nnheader-callback-function) - (with-current-buffer (or to-buffer nntp-server-buffer) - (erase-buffer) - (let ((data (imap-fetch article part prop nil - nnimap-server-buffer))) - ;; data can be nil if article is write-only - (when data - (insert (nnimap-demule (if detail - (nth 2 (car data)) - data))))) - (nnheader-ms-strip-cr) - (gnus-message - 10 "nnimap: Fetching (part of) article %d from %s...done" - article (or (nnimap-decode-group-name group) - (imap-current-mailbox) - (nnimap-decode-group-name gnus-newsgroup-name))) - (if (bobp) - (nnheader-report 'nnimap "No such article %d in %s: %s" - article (or (nnimap-decode-group-name group) - (imap-current-mailbox) - (nnimap-decode-group-name - gnus-newsgroup-name)) - (imap-error-text nnimap-server-buffer)) - (cons group article))) - (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)))))) - -(deffoo nnimap-asynchronous-p () + (or (nnimap-find-connection nntp-server-buffer) + (nnimap-open-connection nntp-server-buffer)))) + +(defun nnimap-make-process-buffer (buffer) + (with-current-buffer + (generate-new-buffer (format "*nnimap %s %s %s*" + nnimap-address nnimap-server-port + (gnus-buffer-exists-p buffer))) + (mm-disable-multibyte) + (buffer-disable-undo) + (gnus-add-buffer) + (set (make-local-variable 'after-change-functions) nil) + (set (make-local-variable 'nnimap-object) (make-nnimap)) + (push (list buffer (current-buffer)) nnimap-connection-alist) + (current-buffer))) + +(defun nnimap-open-shell-stream (name buffer host port) + (let ((process (start-process name buffer shell-file-name + shell-command-switch + (format-spec + nnimap-shell-program + (format-spec-make + ?s host + ?p port))))) + process)) + +(defun nnimap-open-connection (buffer) + (with-current-buffer (nnimap-make-process-buffer buffer) + (let* ((coding-system-for-read 'binary) + (coding-system-for-write 'binary) + (credentials + (cond + ((eq nnimap-stream 'network) + (open-network-stream "*nnimap*" (current-buffer) nnimap-address + (or nnimap-server-port + (if (netrc-find-service-number "imap") + "imap" + "143"))) + (auth-source-user-or-password + '("login" "password") nnimap-address "imap" nil t)) + ((eq nnimap-stream 'stream) + (nnimap-open-shell-stream + "*nnimap*" (current-buffer) nnimap-address + (or nnimap-server-port "imap")) + (auth-source-user-or-password + '("login" "password") nnimap-address "imap" nil t)) + ((eq nnimap-stream 'ssl) + (open-tls-stream "*nnimap*" (current-buffer) nnimap-address + (or nnimap-server-port + (if (netrc-find-service-number "imaps") + "imaps" + "993"))) + (or + (auth-source-user-or-password + '("login" "password") nnimap-address "imap") + (auth-source-user-or-password + '("login" "password") nnimap-address "imaps" nil t)))))) + (setf (nnimap-process nnimap-object) + (get-buffer-process (current-buffer))) + (unless credentials + (delete-process (nnimap-process nnimap-object))) + (when (and (nnimap-process nnimap-object) + (memq (process-status (nnimap-process nnimap-object)) + '(open run))) + (gnus-set-process-query-on-exit-flag (nnimap-process nnimap-object) nil) + (let ((result (nnimap-command "LOGIN %S %S" + (car credentials) (cadr credentials)))) + (if (not (car result)) + (progn + (delete-process (nnimap-process nnimap-object)) + nil) + (setf (nnimap-capabilities nnimap-object) + (mapcar + #'upcase + (or (nnimap-find-parameter "CAPABILITY" (cdr result)) + (nnimap-find-parameter + "CAPABILITY" (cdr (nnimap-command "CAPABILITY")))))) + (when (member "QRESYNC" (nnimap-capabilities nnimap-object)) + (nnimap-command "ENABLE QRESYNC")) + t)))))) + +(defun nnimap-find-parameter (parameter elems) + (let (result) + (dolist (elem elems) + (cond + ((equal (car elem) parameter) + (setq result (cdr elem))) + ((and (equal (car elem) "OK") + (consp (cadr elem)) + (equal (caadr elem) parameter)) + (setq result (cdr (cadr elem)))))) + result)) + +(defun nnimap-close-server (&optional server) t) -(deffoo nnimap-request-article (article &optional 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) - (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) - (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 - group - (gnus-get-info (nnimap-group-prefixed-name group 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))) - (nnheader-report 'nnimap "Could not get active info for %s" - group)) - (t - (nnheader-insert "211 %d %d %d %s\n" (or (nth 0 info) 0) - (max 1 (or (nth 1 info) 1)) - (or (nth 2 info) 0) group) - (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 (nnimap-decode-group-name group) - 'unseen nnimap-server-buffer))) - nnimap-mailbox-info)) +(defun nnimap-request-close () + t) -(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) - (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)))) - -(defun nnimap-pattern-to-list-arguments (pattern) - (mapcar (lambda (p) - (cons (car-safe p) (or (cdr-safe p) p))) - (if (and (listp pattern) - (listp (cdr pattern))) - pattern - (list pattern)))) - -(deffoo nnimap-request-list (&optional server) - (when (nnimap-possibly-change-server server) - (with-current-buffer nntp-server-buffer - (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 - (cdr pattern) (car pattern))) - (unless (member "\\noselect" - (mapcar #'downcase - (imap-mailbox-get 'list-flags mbx))) - (let* ((encoded-mbx (nnimap-encode-group-name mbx)) - (info (nnimap-find-minmax-uid encoded-mbx 'examine))) - (when info - (with-current-buffer nntp-server-buffer - (insert (format "\"%s\" %d %d y\n" - encoded-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)) +(defun nnimap-server-opened (&optional server) + (and (nnoo-current-server-p 'nnimap server) + nntp-server-buffer + (gnus-buffer-live-p nntp-server-buffer) + (nnimap-find-connection nntp-server-buffer))) -(deffoo nnimap-request-post (&optional server) - (let ((success t)) - (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) - (if (gnus-y-or-n-p (format "No such group: %s. Create it? " - to-newsgroup)) - (or (and (gnus-request-create-group - to-newsgroup gnus-command-method) - (gnus-activate-group to-newsgroup nil nil - gnus-command-method)) - (error "Couldn't create group %s" to-newsgroup))) - (error "No such group: %s" to-newsgroup)) - (unless (nnimap-request-accept-article mbx (nth 1 gnus-command-method)) - (setq success nil)))))) - -;; 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...") - (with-current-buffer nntp-server-buffer - (erase-buffer) - (nnimap-before-find-minmax-bugworkaround) - (let (asyncgroups slowgroups decoded-group) - (if (null nnimap-retrieve-groups-asynchronous) - (setq slowgroups groups) - (dolist (group groups) - (setq decoded-group (nnimap-decode-group-name group)) - (gnus-message 9 "nnimap: Quickly checking mailbox %s" - decoded-group) - (add-to-list (if (gnus-group-get-parameter - (nnimap-group-prefixed-name group) - 'imap-status) - 'asyncgroups - 'slowgroups) - (list group (imap-mailbox-status-asynch - decoded-group - '(uidvalidity uidnext unseen) - nnimap-server-buffer)))) - (dolist (asyncgroup asyncgroups) - (let* ((group (nth 0 asyncgroup)) - (tag (nth 1 asyncgroup)) - (gnusgroup (nnimap-group-prefixed-name group)) - (saved-uidvalidity (gnus-group-get-parameter gnusgroup - 'uidvalidity)) - (saved-imap-status (gnus-group-get-parameter gnusgroup - 'imap-status)) - (saved-info (and saved-imap-status - (split-string saved-imap-status " ")))) - (setq decoded-group (nnimap-decode-group-name group)) - (when (imap-ok-p (imap-wait-for-tag tag nnimap-server-buffer)) - (if (or (not (equal - saved-uidvalidity - (imap-mailbox-get 'uidvalidity decoded-group - nnimap-server-buffer))) - (not (equal - (nth 0 saved-info) - (imap-mailbox-get 'uidnext decoded-group - nnimap-server-buffer)))) - (push (list group) slowgroups) - (gnus-sethash - (gnus-group-prefixed-name group server) - (list (imap-mailbox-get 'uidvalidity - decoded-group nnimap-server-buffer) - (imap-mailbox-get 'uidnext - decoded-group nnimap-server-buffer) - (imap-mailbox-get 'unseen - decoded-group nnimap-server-buffer)) - nnimap-mailbox-info) - (insert (format "\"%s\" %s %s y\n" group - (nth 2 saved-info) - (nth 1 saved-info)))))))) - (dolist (group slowgroups) - (if nnimap-retrieve-groups-asynchronous - (setq group (car group))) - (setq decoded-group (nnimap-decode-group-name group)) - (gnus-message 7 "nnimap: Mailbox %s modified" decoded-group) - (or (member "\\NoSelect" (imap-mailbox-get 'list-flags decoded-group - nnimap-server-buffer)) - (let* ((gnusgroup (nnimap-group-prefixed-name group)) - (status (imap-mailbox-status - decoded-group '(uidvalidity uidnext unseen) - nnimap-server-buffer)) - (info (nnimap-find-minmax-uid group 'examine)) - (min-uid (max 1 (or (nth 1 info) 1))) - (max-uid (or (nth 2 info) 0))) - (when (> (or (imap-mailbox-get 'recent decoded-group - nnimap-server-buffer) 0) - 0) - (push (list (cons decoded-group 0)) nnmail-split-history)) - (insert (format "\"%s\" %d %d y\n" group max-uid min-uid)) - (gnus-sethash - (gnus-group-prefixed-name group server) - status - nnimap-mailbox-info) - (if (not (equal (nth 0 status) - (gnus-group-get-parameter gnusgroup - 'uidvalidity))) - (nnimap-verify-uidvalidity group nnimap-current-server)) - ;; The imap-status parameter is a string on the form - ;; "<uidnext> <min-uid> <max-uid>". - (gnus-group-add-parameter - gnusgroup - (cons 'imap-status - (format "%s %s %s" (nth 1 status) min-uid max-uid)))))))) - (gnus-message 5 "nnimap: Checking mailboxes...done") - 'active)) - -(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? - (with-current-buffer nnimap-server-buffer - (gnus-message 5 "nnimap: Updating info for %s..." - (nnimap-decode-group-name (gnus-info-group info))) - - (when (nnimap-mark-permanent-p 'read) - (let (seen unseen) - ;; read info could contain articles marked unread by other - ;; imap clients! we correct this - (setq unseen (gnus-compress-sequence - (imap-search "UNSEEN UNDELETED")) - seen (gnus-range-difference (gnus-info-read info) unseen) - seen (gnus-range-add seen - (gnus-compress-sequence - (imap-search "SEEN"))) - seen (if (and (integerp (car seen)) - (null (cdr seen))) - (list (cons (car seen) (car seen))) - seen)) - (gnus-info-set-read info seen))) - - (dolist (pred gnus-article-mark-lists) - (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 - (gnus-update-alist-soft - (cdr pred) - (gnus-compress-sequence - (imap-search (nnimap-mark-to-predicate (cdr pred)))) - (gnus-info-marks info)) - t))) - - (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" - (nnimap-decode-group-name (gnus-info-group info))) - - info)))) - -(deffoo nnimap-request-type (group &optional article) - (if (and nnimap-news-groups (string-match nnimap-news-groups group)) - 'news - 'mail)) - -(deffoo nnimap-request-set-mark (group actions &optional server) - (when (nnimap-possibly-change-group group server) - (with-current-buffer nnimap-server-buffer - (let (action) - (gnus-message 7 "nnimap: Setting marks in %s..." - (nnimap-decode-group-name group)) - (while (setq action (pop actions)) - (let ((range (nth 0 action)) - (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)) - ;; 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 - (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 - (imap-range-to-message-set range) - (nnimap-mark-to-flag marks nil t))) - ((eq what 'add) - (imap-message-flags-add - (imap-range-to-message-set range) - (nnimap-mark-to-flag marks nil t))) - ((eq what 'set) - (imap-message-flags-set - (imap-range-to-message-set range) - (nnimap-mark-to-flag marks nil t))))))) - (gnus-message 7 "nnimap: Setting marks in %s...done" - (nnimap-decode-group-name group))))) - nil) +(defun nnimap-status-message (&optional server) + nnimap-status-string) -(defun nnimap-split-fancy () - "Like the function `nnmail-split-fancy', but uses `nnimap-split-fancy'." - (let ((nnmail-split-fancy nnimap-split-fancy)) - (nnmail-split-fancy))) - -(defun nnimap-split-to-groups (rules) - ;; tries to match all rules in nnimap-split-rule against content of - ;; nntp-server-buffer, returns a list of groups that matched. - ;; Note: This function takes and returns decoded group names. +(defun nnimap-request-article (article &optional group server to-buffer) (with-current-buffer nntp-server-buffer - ;; Fold continuation lines. - (goto-char (point-min)) - (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) - (replace-match " " t t)) - (if (functionp rules) - (funcall rules) - (let (to-groups regrepp) - (catch 'split-done - (dolist (rule rules to-groups) - (let ((group (car rule)) - (regexp (cadr rule))) + (let ((result (nnimap-possibly-change-group group server))) + (when (stringp article) + (setq article (nnimap-find-article-by-message-id group article))) + (when (and result + article) + (erase-buffer) + (with-current-buffer (nnimap-buffer) + (erase-buffer) + (setq result + (nnimap-command + (if (member "IMAP4REV1" (nnimap-capabilities nnimap-object)) + "UID FETCH %d BODY.PEEK[]" + "UID FETCH %d RFC822.PEEK") + article))) + (let ((buffer (nnimap-find-process-buffer (current-buffer)))) + (when (car result) + (with-current-buffer to-buffer + (insert-buffer-substring buffer) (goto-char (point-min)) - (when (and (if (stringp regexp) - (progn - (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. - (not (assoc group to-groups))) - (push (if regrepp - (nnmail-expand-newtext group) - group) - 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) - (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) - nnimap-split-inbox - (list nnimap-split-inbox))) - -(defun nnimap-split-articles (&optional group server) - ;; Note: Assumes decoded group names in nnimap-split-inbox, - ;; nnimap-split-rule, nnimap-split-fancy, and nnmail-split-history. - (when (nnimap-possibly-change-server server) - (with-current-buffer nnimap-server-buffer - (let (rule inbox removeorig - (inboxes (nnimap-split-find-inbox server))) - ;; iterate over inboxes - (while (and (setq inbox (pop inboxes)) - (nnimap-possibly-change-group - (nnimap-encode-group-name 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 nnimap-split-predicate)) - (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)) - (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) - (when nnmail-cache-accepted-message-ids - (with-current-buffer nntp-server-buffer - (let (msgid) - (and (setq msgid - (nnmail-fetch-field "message-id")) - (nnmail-cache-insert msgid - (nnimap-encode-group-name 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) - "\\Seen \\Deleted"))))) - (when (imap-mailbox-select inbox) ;; just in case - ;; todo: UID EXPUNGE (if available) to remove splitted articles - (imap-mailbox-expunge) - (imap-mailbox-close))) - (when nnmail-cache-accepted-message-ids - (nnmail-cache-close)) + (let ((bytes (nnimap-get-length))) + (delete-region (line-beginning-position) + (progn (forward-line 1) (point))) + (goto-char (+ (point) bytes)) + (delete-region (point) (point-max)) + (nnheader-ms-strip-cr)) + t))))))) + +(defun nnimap-request-group (group &optional server dont-check) + (with-current-buffer nntp-server-buffer + (let ((result (nnimap-possibly-change-group group server)) + articles) + (when result + (setq articles (nnimap-get-flags "1:*")) + (erase-buffer) + (insert + (format + "211 %d %d %d %S\n" + (length articles) + (or (caar articles) 0) + (or (caar (last articles)) 0) + group)) t)))) -(deffoo nnimap-request-scan (&optional group server) - (nnimap-split-articles group server)) - -(deffoo nnimap-request-newgroups (date &optional server) - (when (nnimap-possibly-change-server server) - (with-current-buffer nntp-server-buffer - (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s..." - (if (> (length server) 0) " on " "") server) +(defun nnimap-get-flags (spec) + (let ((articles nil) + elems) + (with-current-buffer (nnimap-buffer) (erase-buffer) - (nnimap-before-find-minmax-bugworkaround) - (dolist (pattern (nnimap-pattern-to-list-arguments - nnimap-list-pattern)) - (dolist (mbx (funcall nnimap-request-list-method (cdr pattern) (car pattern) nil - 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* ((encoded-mbx (nnimap-encode-group-name mbx)) - (info (nnimap-find-minmax-uid encoded-mbx 'examine))) - (when info - (insert (format "\"%s\" %d %d y\n" - encoded-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)) + (nnimap-wait-for-response (nnimap-send-command + "UID FETCH %s FLAGS" spec)) + (goto-char (point-min)) + (while (re-search-forward "^\\* [0-9]+ FETCH (\\(.*\\))" nil t) + (setq elems (nnimap-parse-line (match-string 1))) + (push (cons (string-to-number (cadr (member "UID" elems))) + (cadr (member "FLAGS" elems))) + articles))) + (nreverse articles))) -(deffoo nnimap-request-create-group (group &optional server args) - (when (nnimap-possibly-change-server server) - (let ((decoded-group (nnimap-decode-group-name group))) - (or (imap-mailbox-status decoded-group 'uidvalidity nnimap-server-buffer) - (imap-mailbox-create decoded-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." - (let* ((ms (- (car time1) (car time2))) - (ls (- (nth 1 time1) (nth 1 time2)))) - (if (< ls 0) - (list (- ms 1) (+ (expt 2 16) ls)) - (list ms ls)))) - -(eval-when-compile (require 'parse-time)) -(defun nnimap-date-days-ago (daysago) - "Return date, in format \"3-Aug-1998\", for DAYSAGO days ago." - (require 'parse-time) - (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))) - -(defun nnimap-request-expire-articles-progress () - (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 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 - (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)))))) - ((and nnimap-search-uids-not-since-is-evil (numberp days)) - (let* ((all-new-articles - (gnus-compress-sequence - (imap-search (format "SINCE %s" - (nnimap-date-days-ago days))))) - (oldartseq - (gnus-range-difference artseq all-new-articles)) - (oldarts (gnus-uncompress-range oldartseq))) - (when oldarts - (nnimap-expiry-target oldarts group server) - (when (imap-message-flags-add - (imap-range-to-message-set oldartseq) - "\\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) - (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) +(defun nnimap-close-group (group &optional server) + t) (deffoo nnimap-request-move-article (article group server accept-form - &optional last move-is-internal) - (when (nnimap-possibly-change-server server) - (save-excursion - (let ((buf (get-buffer-create " *nnimap move*")) - (nnimap-current-move-article article) - (nnimap-current-move-group group) - (nnimap-current-move-server nnimap-current-server) - result) - (gnus-message 10 "nnimap-request-move-article: this is an %s move" - (if move-is-internal - "internal" - "external")) - ;; request the article only when the move is NOT internal - (and (or move-is-internal - (nnimap-request-article article group server)) - (with-current-buffer buf - (buffer-disable-undo (current-buffer)) - (insert-buffer-substring nntp-server-buffer) - (setq result (eval accept-form)) - (kill-buffer buf) - result) - (nnimap-possibly-change-group group server) - (imap-message-flags-add - (imap-range-to-message-set (list article)) - "\\Deleted" 'silent nnimap-server-buffer)) - result)))) + &optional last internal-move-group) + (when (nnimap-possibly-change-group group server) + ;; If the move is internal (on the same server), just do it the easy + ;; way. + (let ((message-id (message-field-value "message-id"))) + (if internal-move-group + (let ((result + (with-current-buffer (nnimap-buffer) + (nnimap-command "UID COPY %d %S" + article + (utf7-encode internal-move-group t))))) + (when (car result) + (nnimap-delete-article article) + (cons internal-move-group + (nnimap-find-article-by-message-id + internal-move-group message-id)))) + (with-temp-buffer + (let ((result (eval accept-form))) + (when result + (nnimap-delete-article article) + result))))))) + +(deffoo nnimap-request-expire-articles (articles group &optional server force) + (cond + ((not (nnimap-possibly-change-group group server)) + articles) + (force + (unless (nnimap-delete-article articles) + (message "Article marked for deletion, but not expunged.")) + nil) + (t + articles))) + +(defun nnimap-find-article-by-message-id (group message-id) + (when (nnimap-possibly-change-group group nil) + (with-current-buffer (nnimap-buffer) + (let ((result + (nnimap-command "UID SEARCH HEADER Message-Id %S" message-id)) + article) + (when (car result) + ;; Select the last instance of the message in the group. + (and (setq article + (car (last (assoc "SEARCH" (cdr result))))) + (string-to-number article))))))) + +(defun nnimap-delete-article (articles) + (with-current-buffer (nnimap-buffer) + (nnimap-command "UID STORE %s +FLAGS.SILENT (\\Deleted)" + (nnimap-article-ranges articles)) + (when (member "UIDPLUS" (nnimap-capabilities nnimap-object)) + (nnimap-send-command "UID EXPUNGE %s" + (nnimap-article-ranges articles)) + t))) + +(deffoo nnimap-request-scan (&optional group server) + (when (and (nnimap-possibly-change-group nil server) + (equal group nnimap-inbox) + nnimap-inbox + nnimap-split-methods) + (nnimap-split-incoming-mail))) + +(defun nnimap-marks-to-flags (marks) + (let (flags flag) + (dolist (mark marks) + (when (setq flag (cadr (assq mark nnimap-mark-alist))) + (push flag flags))) + flags)) + +(defun nnimap-request-set-mark (group actions &optional server) + (when (nnimap-possibly-change-group group server) + (let (sequence) + (with-current-buffer (nnimap-buffer) + ;; Just send all the STORE commands without waiting for + ;; response. If they're successful, they're successful. + (dolist (action actions) + (destructuring-bind (range action marks) action + (let ((flags (nnimap-marks-to-flags marks))) + (when flags + (setq sequence (nnimap-send-command + "UID STORE %s %sFLAGS.SILENT (%s)" + (nnimap-article-ranges range) + (if (eq action 'del) + "-" + "+") + (mapconcat #'identity flags " "))))))) + ;; Wait for the last command to complete to avoid later + ;; syncronisation problems with the stream. + (nnimap-wait-for-response sequence))))) (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... - (and (nnimap-possibly-change-group - nnimap-current-move-group) - (imap-message-copy (number-to-string - nnimap-current-move-article) - (nnimap-decode-group-name group) - 'dontcreate nil - nnimap-server-buffer)) - (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[^:]") - (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 - (nnmail-fetch-field "subject")))) - (when (and last nnmail-cache-accepted-message-ids) - (nnmail-cache-close)) - ;; this 'or' is for Cyrus server bug - (or (null (imap-current-mailbox nnimap-server-buffer)) - (imap-mailbox-unselect nnimap-server-buffer)) - (imap-message-append (nnimap-decode-group-name group) - (current-buffer) nil nil - nnimap-server-buffer))) - (cons group (nth 1 uid)) - (nnheader-report 'nnimap (imap-error-text nnimap-server-buffer)))))) - -(deffoo nnimap-request-delete-group (group force &optional server) - (when (nnimap-possibly-change-server server) - (setq group (nnimap-decode-group-name group)) - (when (string= group (imap-current-mailbox nnimap-server-buffer)) - (imap-mailbox-unselect nnimap-server-buffer)) - (with-current-buffer nnimap-server-buffer - (if force - (or (null (imap-mailbox-status group 'uidvalidity)) - (imap-mailbox-delete group)) - ;; UNSUBSCRIBE? + (when (nnimap-possibly-change-group nil server) + (nnmail-check-syntax) + (let ((message (buffer-string)) + (message-id (message-field-value "message-id")) + sequence) + (with-current-buffer (nnimap-buffer) + (setq sequence (nnimap-send-command + "APPEND %S {%d}" (utf7-encode group t) + (length message))) + (process-send-string (get-buffer-process (current-buffer)) message) + (process-send-string (get-buffer-process (current-buffer)) "\r\n") + (let ((result (nnimap-get-response sequence))) + (when result + (cons group + (nnimap-find-article-by-message-id group message-id)))))))) + +(defun nnimap-add-cr () + (goto-char (point-min)) + (while (re-search-forward "\r?\n" nil t) + (replace-match "\r\n" t t))) + +(defun nnimap-get-groups () + (let ((result (nnimap-command "LIST \"\" \"*\"")) + groups) + (when (car result) + (dolist (line (cdr result)) + (when (and (equal (car line) "LIST") + (not (and (caadr line) + (string-match "noselect" (caadr line))))) + (push (car (last line)) groups))) + (nreverse groups)))) + +(defun nnimap-request-list (&optional server) + (nnimap-possibly-change-group nil server) + (with-current-buffer nntp-server-buffer + (erase-buffer) + (let ((groups + (with-current-buffer (nnimap-buffer) + (nnimap-get-groups))) + sequences responses) + (when groups + (with-current-buffer (nnimap-buffer) + (dolist (group groups) + (push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t)) + group) + sequences)) + (nnimap-wait-for-response (caar sequences)) + (setq responses + (nnimap-get-responses (mapcar #'car sequences)))) + (dolist (response responses) + (let* ((sequence (car response)) + (response (cadr response)) + (group (cadr (assoc sequence sequences)))) + (when (and group + (equal (caar response) "OK")) + (let ((uidnext (nnimap-find-parameter "UIDNEXT" response)) + highest exists) + (dolist (elem response) + (when (equal (cadr elem) "EXISTS") + (setq exists (string-to-number (car elem))))) + (when uidnext + (setq highest (1- (string-to-number (car uidnext))))) + (cond + ((null highest) + (insert (format "%S 0 1 y\n" (utf7-decode group t)))) + ((zerop exists) + ;; Empty group. + (insert (format "%S %d %d y\n" + (utf7-decode group t) highest (1+ highest)))) + (t + ;; Return the widest possible range. + (insert (format "%S %d 1 y\n" (utf7-decode group t) + (or highest exists))))))))) t)))) -(deffoo nnimap-request-rename-group (group new-name &optional server) - (when (nnimap-possibly-change-server server) - (imap-mailbox-rename (nnimap-decode-group-name group) - (nnimap-decode-group-name new-name) - nnimap-server-buffer))) - -(defun nnimap-expunge (mailbox server) - (when (nnimap-possibly-change-group mailbox server) - (imap-mailbox-expunge nil nnimap-server-buffer))) - -(defun nnimap-acl-get (mailbox server) - (when (nnimap-possibly-change-server server) - (and (imap-capability 'ACL nnimap-server-buffer) - (imap-mailbox-acl-get (nnimap-decode-group-name mailbox) - nnimap-server-buffer)))) - -(defun nnimap-acl-edit (mailbox method old-acls new-acls) - (when (nnimap-possibly-change-server (cadr method)) - (unless (imap-capability 'ACL nnimap-server-buffer) - (error "Your server does not support ACL editing")) - (with-current-buffer nnimap-server-buffer - ;; delete all removed identifiers - (mapc (lambda (old-acl) - (unless (assoc (car old-acl) new-acls) - (or (imap-mailbox-acl-delete (car old-acl) - (nnimap-decode-group-name mailbox)) - (error "Can't delete ACL for %s" (car old-acl))))) - old-acls) - ;; set all changed acl's - (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 - (nnimap-decode-group-name mailbox)) - (error "Can't set ACL for %s to %s" (car new-acl) - new-rights))))) - new-acls) - t))) +(defun nnimap-retrieve-group-data-early (server infos) + (when (nnimap-possibly-change-group nil server) + (with-current-buffer (nnimap-buffer) + ;; QRESYNC handling isn't implemented. + (let ((qresyncp (member "notQRESYNC" (nnimap-capabilities nnimap-object))) + marks groups sequences) + ;; Go through the infos and gather the data needed to know + ;; what and how to request the data. + (dolist (info infos) + (setq marks (gnus-info-marks info)) + (push (list (gnus-group-real-name (gnus-info-group info)) + (cdr (assq 'active marks)) + (cdr (assq 'uid marks))) + groups)) + ;; Then request the data. + (erase-buffer) + (dolist (elem groups) + (if (and qresyncp + (nth 2 elem)) + (push + (list 'qresync + (nnimap-send-command "EXAMINE %S (QRESYNC (%s %s))" + (car elem) + (car (nth 2 elem)) + (cdr (nth 2 elem))) + nil + (car elem)) + sequences) + (let ((start + (if (nth 1 elem) + ;; Fetch the last 100 flags. + (max 1 (- (cdr (nth 1 elem)) 100)) + 1))) + (push (list (nnimap-send-command "EXAMINE %S" (car elem)) + (nnimap-send-command "UID FETCH %d:* FLAGS" start) + start + (car elem)) + sequences)))) + sequences)))) + +(defun nnimap-finish-retrieve-group-infos (server infos sequences) + (when (and sequences + (nnimap-possibly-change-group nil server)) + (with-current-buffer (nnimap-buffer) + ;; Wait for the final data to trickle in. + (nnimap-wait-for-response (cadar sequences)) + ;; Now we should have all the data we need, no matter whether + ;; we're QRESYNCING, fetching all the flags from scratch, or + ;; just fetching the last 100 flags per group. + (nnimap-update-infos (nnimap-flags-to-marks + (nnimap-parse-flags + (nreverse sequences))) + infos)))) + +(defun nnimap-update-infos (flags infos) + (dolist (info infos) + (let ((group (gnus-group-real-name (gnus-info-group info)))) + (nnimap-update-info info (cdr (assoc group flags)))))) + +(defun nnimap-update-info (info marks) + (when marks + (destructuring-bind (existing flags high low uidnext start-article) marks + (let ((group (gnus-info-group info)) + (completep (and start-article + (= start-article 1)))) + ;; First set the active ranges based on high/low. + (if (or completep + (not (gnus-active group))) + (gnus-set-active group + (if high + (cons low high) + ;; No articles in this group. + (cons (1- uidnext) uidnext))) + (setcdr (gnus-active group) high)) + ;; Then update the list of read articles. + (let* ((unread + (gnus-compress-sequence + (gnus-set-difference + (gnus-set-difference + existing + (cdr (assoc "\\Seen" flags))) + (cdr (assoc "\\Flagged" flags))))) + (read (gnus-range-difference + (cons start-article high) unread))) + (when (> start-article 1) + (setq read + (gnus-range-nconcat + (gnus-sorted-range-intersection + (cons 1 start-article) + (gnus-info-read info)) + read))) + (gnus-info-set-read info read) + ;; Update the marks. + (setq marks (gnus-info-marks info)) + ;; Note the active level for the next run-through. + (let ((active (assq 'active marks))) + (if active + (setcdr active (gnus-active group)) + (push (cons 'active (gnus-active group)) marks))) + (dolist (type (cdr nnimap-mark-alist)) + (let ((old-marks (assoc (car type) marks)) + (new-marks (gnus-compress-sequence + (cdr (assoc (cadr type) flags))))) + (setq marks (delq old-marks marks)) + (pop old-marks) + (when (and old-marks + (> start-article 1)) + (setq old-marks (gnus-range-difference + (cons start-article high) + old-marks)) + (setq new-marks (gnus-range-nconcat old-marks new-marks))) + (when new-marks + (push (cons (car type) new-marks) marks))) + (gnus-info-set-marks info marks))))))) + +(defun nnimap-flags-to-marks (groups) + (let (data group totalp uidnext articles start-article mark) + (dolist (elem groups) + (setq group (car elem) + uidnext (cadr elem) + start-article (caddr elem) + articles (cdddr elem)) + (let ((high (caar articles)) + marks low existing) + (dolist (article articles) + (setq low (car article)) + (push (car article) existing) + (dolist (flag (cdr article)) + (setq mark (assoc flag marks)) + (if (not mark) + (push (list flag (car article)) marks) + (setcdr mark (cons (car article) (cdr mark))))) + (push (list group existing marks high low uidnext start-article) + data)))) + data)) + +(defun nnimap-parse-flags (sequences) + (goto-char (point-min)) + (let (start end articles groups uidnext elems) + (dolist (elem sequences) + (destructuring-bind (group-sequence flag-sequence totalp group) elem + ;; The EXAMINE was successful. + (when (and (search-forward (format "\n%d OK " group-sequence) nil t) + (progn + (forward-line 1) + (setq start (point)) + (if (re-search-backward "UIDNEXT \\([0-9]+\\)" + (or end (point-min)) t) + (setq uidnext (string-to-number (match-string 1))) + (setq uidnext nil)) + (goto-char start)) + ;; The UID FETCH FLAGS was successful. + (search-forward (format "\n%d OK " flag-sequence) nil t)) + (setq end (point)) + (goto-char start) + (while (re-search-forward "^\\* [0-9]+ FETCH (\\(.*\\))" end t) + (setq elems (nnimap-parse-line (match-string 1))) + (push (cons (string-to-number (cadr (member "UID" elems))) + (cadr (member "FLAGS" elems))) + articles)) + (push (nconc (list group uidnext totalp) articles) groups) + (setq articles nil)))) + groups)) + +(defun nnimap-find-process-buffer (buffer) + (cadr (assoc buffer nnimap-connection-alist))) + +(defun nnimap-request-post (&optional server) + (setq nnimap-status-string "Read-only server") + nil) - -;;; Internal functions - -;; -;; This is confusing. -;; -;; mark => read, tick, draft, reply etc -;; flag => "\\Seen", "\\Flagged", "\\Draft", "gnus-expire" etc -;; predicate => "SEEN", "FLAGGED", "DRAFT", "KEYWORD gnus-expire" etc -;; -;; Mark should not really contain 'read since it's not a "mark" in the Gnus -;; world, but we cheat. Mark == gnus-article-mark-lists + '(read . read). -;; - -(defconst nnimap-mark-to-predicate-alist - (mapcar - (lambda (pair) ; cdr is the mark - (or (assoc (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) - "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP predicate. -This is a string such as \"SEEN\", \"FLAGGED\", \"KEYWORD gnus-expire\", -to be used within a IMAP SEARCH query." - (cdr (assq pred nnimap-mark-to-predicate-alist))) - -(defconst nnimap-mark-to-flag-alist - (mapcar - (lambda (pair) - (or (assoc (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) - (if (and (not (null preds)) (listp preds)) - (cons (nnimap-mark-to-flag (car preds)) - (nnimap-mark-to-flag (cdr preds))) - (cdr (assoc preds nnimap-mark-to-flag-alist)))) - -(defun nnimap-mark-to-flag (preds &optional always-list make-string) - "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP flag. -This is a string such as \"\\Seen\", \"\\Flagged\", \"gnus-expire\", to -be used in a STORE FLAGS command." - (let ((result (nnimap-mark-to-flag-1 preds))) - (setq result (if (and (or make-string always-list) - (not (listp result))) - (list result) - result)) - (if make-string - (mapconcat (lambda (flag) - (if (listp flag) - (mapconcat 'identity flag " ") - flag)) - result " ") - result))) - -(defun nnimap-mark-permanent-p (mark &optional group) - "Return t if MARK can be permanently (between IMAP sessions) saved on articles, in GROUP." - (imap-message-flag-permanent-p (nnimap-mark-to-flag mark))) +(defun nnimap-possibly-change-group (group server) + (let ((open-result t)) + (when (and server + (not (nnimap-server-opened server))) + (setq open-result (nnimap-open-server server))) + (cond + ((not open-result) + nil) + ((not group) + t) + (t + (with-current-buffer (nnimap-buffer) + (if (equal group (nnimap-group nnimap-object)) + t + (let ((result (nnimap-command "SELECT %S" (utf7-encode group t)))) + (when (car result) + (setf (nnimap-group nnimap-object) group) + result)))))))) + +(defun nnimap-find-connection (buffer) + "Find the connection delivering to BUFFER." + (let ((entry (assoc buffer nnimap-connection-alist))) + (when entry + (if (and (buffer-name (cadr entry)) + (get-buffer-process (cadr entry)) + (memq (process-status (get-buffer-process (cadr entry))) + '(open run))) + (get-buffer-process (cadr entry)) + (setq nnimap-connection-alist (delq entry nnimap-connection-alist)) + nil)))) + +(defvar nnimap-sequence 0) + +(defun nnimap-send-command (&rest args) + (process-send-string + (get-buffer-process (current-buffer)) + (nnimap-log-command + (format "%d %s\r\n" + (incf nnimap-sequence) + (apply #'format args)))) + nnimap-sequence) + +(defun nnimap-log-command (command) + (with-current-buffer (get-buffer-create "*imap log*") + (goto-char (point-max)) + (insert (format-time-string "%H:%M:%S") " " command)) + command) + +(defun nnimap-command (&rest args) + (erase-buffer) + (let* ((sequence (apply #'nnimap-send-command args)) + (response (nnimap-get-response sequence))) + (if (equal (caar response) "OK") + (cons t response) + (nnheader-report 'nnimap "%s" + (mapconcat #'identity (car response) " ")) + nil))) + +(defun nnimap-get-response (sequence) + (nnimap-wait-for-response sequence) + (nnimap-parse-response)) + +(defun nnimap-wait-for-response (sequence &optional messagep) + (goto-char (point-max)) + (while (or (bobp) + (progn + (forward-line -1) + (not (looking-at (format "^%d .*\n" sequence))))) + (when messagep + (message "Read %dKB" (/ (buffer-size) 1000))) + (nnheader-accept-process-output (get-buffer-process (current-buffer))) + (goto-char (point-max)))) + +(defun nnimap-parse-response () + (let ((lines (split-string (nnimap-last-response-string) "\r\n" t)) + result) + (dolist (line lines) + (push (cdr (nnimap-parse-line line)) result)) + ;; Return the OK/error code first, and then all the "continuation + ;; lines" afterwards. + (cons (pop result) + (nreverse result)))) + +;; Parse an IMAP response line lightly. They look like +;; "* OK [UIDVALIDITY 1164213559] UIDs valid", typically, so parse +;; the lines into a list of strings and lists of string. +(defun nnimap-parse-line (line) + (let (char result) + (with-temp-buffer + (insert line) + (goto-char (point-min)) + (while (not (eobp)) + (if (eql (setq char (following-char)) ? ) + (forward-char 1) + (push + (cond + ((eql char ?\[) + (split-string (buffer-substring + (1+ (point)) (1- (search-forward "]"))))) + ((eql char ?\() + (split-string (buffer-substring + (1+ (point)) (1- (search-forward ")"))))) + ((eql char ?\") + (forward-char 1) + (buffer-substring (point) (1- (search-forward "\"")))) + (t + (buffer-substring (point) (if (search-forward " " nil t) + (1- (point)) + (goto-char (point-max)))))) + result))) + (nreverse result)))) + +(defun nnimap-last-response-string () + (save-excursion + (forward-line 1) + (let ((end (point))) + (forward-line -1) + (when (not (bobp)) + (forward-line -1) + (while (and (not (bobp)) + (eql (following-char) ?*)) + (forward-line -1)) + (unless (eql (following-char) ?*) + (forward-line 1))) + (buffer-substring (point) end)))) + +(defun nnimap-get-responses (sequences) + (let (responses) + (dolist (sequence sequences) + (goto-char (point-min)) + (when (re-search-forward (format "^%d " sequence) nil t) + (push (list sequence (nnimap-parse-response)) + responses))) + responses)) + +(defvar nnimap-incoming-split-list nil) + +(defun nnimap-fetch-inbox (articles) + (erase-buffer) + (nnimap-wait-for-response + (nnimap-send-command + "UID FETCH %s %s" + (nnimap-article-ranges articles) + (format "(UID %s%s)" + (format + (if (member "IMAP4REV1" + (nnimap-capabilities nnimap-object)) + "BODY.PEEK[HEADER] BODY.PEEK" + "RFC822.PEEK")) + (if nnimap-split-download-body-default + "" + "[1]"))) + t)) + +(defun nnimap-split-incoming-mail () + (with-current-buffer (nnimap-buffer) + (let ((nnimap-incoming-split-list nil) + (nnmail-split-methods nnimap-split-methods) + (nnmail-inhibit-default-split-group t) + (groups (nnimap-get-groups)) + new-articles) + (erase-buffer) + (nnimap-command "SELECT %S" nnimap-inbox) + (setq new-articles (nnimap-new-articles (nnimap-get-flags "1:*"))) + (when new-articles + (nnimap-fetch-inbox new-articles) + (nnimap-transform-split-mail) + (nnheader-ms-strip-cr) + (nnmail-cache-open) + (nnmail-split-incoming (current-buffer) + #'nnimap-save-mail-spec + nil nil + #'nnimap-dummy-active-number) + (when nnimap-incoming-split-list + (let ((specs (nnimap-make-split-specs nnimap-incoming-split-list)) + sequences) + ;; Create any groups that doesn't already exist on the + ;; server first. + (dolist (spec specs) + (unless (member (car spec) groups) + (nnimap-command "CREATE %S" (utf7-encode (car spec) t)))) + ;; Then copy over all the messages. + (erase-buffer) + (dolist (spec specs) + (let ((group (car spec)) + (ranges (cdr spec))) + (push (list (nnimap-send-command "UID COPY %s %S" + (nnimap-article-ranges ranges) + (utf7-encode group t)) + ranges) + sequences))) + ;; Wait for the last COPY response... + (when sequences + (nnimap-wait-for-response (caar sequences)) + ;; And then mark the successful copy actions as deleted, + ;; and possibly expunge them. + (nnimap-mark-and-expunge-incoming + (nnimap-parse-copied-articles sequences))))))))) + +(defun nnimap-mark-and-expunge-incoming (range) + (when range + (setq range (nnimap-article-ranges range)) + (nnimap-send-command + "UID STORE %s +FLAGS.SILENT (\\Deleted)" range) + (cond + ;; If the server supports it, we now delete the message we have + ;; just copied over. + ((member "UIDPLUS" (nnimap-capabilities nnimap-object)) + (nnimap-send-command "UID EXPUNGE %s" range)) + ;; If it doesn't support UID EXPUNGE, then we only expunge if the + ;; user has configured it. + (nnimap-expunge-inbox + (nnimap-send-command "EXPUNGE"))))) + +(defun nnimap-parse-copied-articles (sequences) + (let (sequence copied range) + (goto-char (point-min)) + (while (re-search-forward "^\\([0-9]+\\) OK " nil t) + (setq sequence (string-to-number (match-string 1))) + (when (setq range (cadr (assq sequence sequences))) + (push (gnus-uncompress-range range) copied))) + (gnus-compress-sequence (sort (apply #'nconc copied) #'<)))) + +(defun nnimap-new-articles (flags) + (let (new) + (dolist (elem flags) + (when (or (null (cdr elem)) + (and (not (member "\\Deleted" (cdr elem))) + (not (member "\\Seen" (cdr elem))))) + (push (car elem) new))) + (gnus-compress-sequence (nreverse new)))) + +(defun nnimap-make-split-specs (list) + (let ((specs nil) + entry) + (dolist (elem list) + (destructuring-bind (article spec) elem + (dolist (group (delete nil (mapcar #'car spec))) + (unless (setq entry (assoc group specs)) + (push (setq entry (list group)) specs)) + (setcdr entry (cons article (cdr entry)))))) + (dolist (entry specs) + (setcdr entry (gnus-compress-sequence (sort (cdr entry) #'<)))) + specs)) + +(defun nnimap-transform-split-mail () + (goto-char (point-min)) + (let (article bytes) + (block nil + (while (not (eobp)) + (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)")) + (delete-region (point) (progn (forward-line 1) (point))) + (when (eobp) + (return))) + (setq article (match-string 1) + bytes (nnimap-get-length)) + (delete-region (line-beginning-position) (line-end-position)) + ;; Insert MMDF separator, and a way to remember what this + ;; article UID is. + (insert (format "\^A\^A\^A\^A\n\nX-nnimap-article: %s" article)) + (forward-char (1+ bytes)) + (setq bytes (nnimap-get-length)) + (delete-region (line-beginning-position) (line-end-position)) + (forward-char (1+ bytes)) + (delete-region (line-beginning-position) (line-end-position)))))) + +(defun nnimap-dummy-active-number (group &optional server) + 1) + +(defun nnimap-save-mail-spec (group-art &optional server full-nov) + (let (article) + (goto-char (point-min)) + (if (not (re-search-forward "X-nnimap-article: \\([0-9]+\\)" nil t)) + (error "Invalid nnimap mail") + (setq article (string-to-number (match-string 1)))) + (push (list article group-art) + nnimap-incoming-split-list))) (provide 'nnimap) |