31717
|
1 ;;; nnimap.el --- imap backend for Gnus
|
|
2 ;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
|
|
3
|
|
4 ;; Author: Simon Josefsson <jas@pdc.kth.se>
|
|
5 ;; Jim Radford <radford@robby.caltech.edu>
|
|
6 ;; Keywords: mail
|
|
7
|
|
8 ;; This file is part of GNU Emacs.
|
|
9
|
|
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
11 ;; it under the terms of the GNU General Public License as published by
|
|
12 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
13 ;; any later version.
|
|
14
|
|
15 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
18 ;; GNU General Public License for more details.
|
|
19
|
|
20 ;; You should have received a copy of the GNU General Public License
|
|
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
23 ;; Boston, MA 02111-1307, USA.
|
|
24
|
|
25 ;;; Commentary:
|
|
26
|
|
27 ;; Todo, major things:
|
|
28 ;;
|
|
29 ;; o Fix Gnus to view correct number of unread/total articles in group buffer
|
|
30 ;; o Fix Gnus to handle leading '.' in group names (fixed?)
|
|
31 ;; o Finish disconnected mode (moving articles between mailboxes unplugged)
|
|
32 ;; o Sieve
|
|
33 ;; o MIME (partial article fetches)
|
|
34 ;; o Split to other backends, different split rules for different
|
|
35 ;; servers/inboxes
|
|
36 ;;
|
|
37 ;; Todo, minor things:
|
|
38 ;;
|
|
39 ;; o Don't require half of Gnus -- backends should be standalone
|
|
40 ;; o Verify that we don't use IMAP4rev1 specific things (RFC2060 App B)
|
|
41 ;; o Dont uid fetch 1,* in nnimap-retrive-groups (slow)
|
|
42 ;; o Split up big fetches (1,* header especially) in smaller chunks
|
|
43 ;; o What do I do with gnus-newsgroup-*?
|
|
44 ;; o Tell Gnus about new groups (how can we tell?)
|
|
45 ;; o Respooling (fix Gnus?) (unnecessery?)
|
|
46 ;; o Add support for the following: (if applicable)
|
|
47 ;; request-list-newsgroups, request-regenerate
|
|
48 ;; list-active-group,
|
|
49 ;; request-associate-buffer, request-restore-buffer,
|
|
50 ;; o Do The Right Thing when UIDVALIDITY changes (what's the right thing?)
|
|
51 ;; o Support RFC2221 (Login referrals)
|
|
52 ;; o IMAP2BIS compatibility? (RFC2061)
|
|
53 ;; o ACAP stuff (perhaps a different project, would be nice to ACAPify
|
|
54 ;; .newsrc.eld)
|
|
55 ;; o What about Gnus's article editing, can we support it? NO!
|
|
56 ;; o Use \Draft to support the draft group??
|
|
57 ;; o Duplicate suppression
|
|
58
|
|
59 ;;; Code:
|
|
60
|
|
61 (eval-and-compile
|
|
62 (require 'imap))
|
|
63
|
|
64 (require 'nnoo)
|
|
65 (require 'nnmail)
|
|
66 (require 'nnheader)
|
|
67 (require 'mm-util)
|
|
68 (require 'gnus)
|
|
69 (require 'gnus-range)
|
|
70 (require 'gnus-start)
|
|
71 (require 'gnus-int)
|
|
72
|
|
73 (nnoo-declare nnimap)
|
|
74
|
|
75 (defconst nnimap-version "nnimap 0.131")
|
|
76
|
|
77 (defvoo nnimap-address nil
|
|
78 "Address of physical IMAP server. If nil, use the virtual server's name.")
|
|
79
|
|
80 (defvoo nnimap-server-port nil
|
|
81 "Port number on physical IMAP server.
|
|
82 If nil, defaults to 993 for SSL connections and 143 otherwise.")
|
|
83
|
|
84 ;; Splitting variables
|
|
85
|
|
86 (defvar nnimap-split-crosspost t
|
|
87 "If non-nil, do crossposting if several split methods match the mail.
|
|
88 If nil, the first match found will be used.")
|
|
89
|
|
90 (defvar nnimap-split-inbox nil
|
|
91 "*Name of mailbox to split mail from.
|
|
92
|
|
93 Mail is read from this mailbox and split according to rules in
|
|
94 `nnimap-split-rules'.
|
|
95
|
|
96 This can be a string or a list of strings.")
|
|
97
|
|
98 (defvar nnimap-split-rule nil
|
|
99 "*Mail will be split according to theese rules.
|
|
100
|
|
101 Mail is read from mailbox(es) specified in `nnimap-split-inbox'.
|
|
102
|
|
103 If you'd like, for instance, one mail group for mail from the
|
|
104 \"gnus-imap\" mailing list, one group for junk mail and leave
|
|
105 everything else in the incoming mailbox, you could do something like
|
|
106 this:
|
|
107
|
|
108 (setq nnimap-split-rule '((\"INBOX.gnus-imap\" \"From:.*gnus-imap\")
|
|
109 (\"INBOX.junk\" \"Subject:.*buy\")))
|
|
110
|
|
111 As you can see, `nnimap-split-rule' is a list of lists, where the first
|
|
112 element in each \"rule\" is the name of the IMAP mailbox, and the
|
|
113 second is a regexp that nnimap will try to match on the header to find
|
|
114 a fit.
|
|
115
|
|
116 The second element can also be a function. In that case, it will be
|
|
117 called narrowed to the headers with the first element of the rule as
|
|
118 the argument. It should return a non-nil value if it thinks that the
|
|
119 mail belongs in that group.
|
|
120
|
|
121 This variable can also have a function as its value, the function will
|
|
122 be called with the headers narrowed and should return a group where it
|
|
123 thinks the article should be splitted to. See `nnimap-split-fancy'.
|
|
124
|
|
125 To allow for different split rules on different virtual servers, and
|
|
126 even different split rules in different inboxes on the same server,
|
|
127 the syntax of this variable have been extended along the lines of:
|
|
128
|
|
129 (setq nnimap-split-rule
|
|
130 '((\"my1server\" (\".*\" ((\"ding\" \"ding@gnus.org\")
|
|
131 (\"junk\" \"From:.*Simon\")))
|
|
132 (\"my2server\" (\"INBOX\" nnimap-split-fancy))
|
|
133 (\"my[34]server\" (\".*\" ((\"private\" \"To:.*Simon\")
|
|
134 (\"junk\" my-junk-func)))))
|
|
135
|
|
136 The virtual server name is in fact a regexp, so that the same rules
|
|
137 may apply to several servers. In the example, the servers
|
|
138 \"my3server\" and \"my4server\" both use the same rules. Similarly,
|
|
139 the inbox string is also a regexp. The actual splitting rules are as
|
|
140 before, either a function, or a list with group/regexp or
|
|
141 group/function elements.")
|
|
142
|
|
143 (defvar nnimap-split-predicate "UNSEEN UNDELETED"
|
|
144 "The predicate used to find articles to split.
|
|
145 If you use another IMAP client to peek on articles but always would
|
|
146 like nnimap to split them once it's started, you could change this to
|
|
147 \"UNDELETED\". Other available predicates are available in
|
|
148 RFC2060 section 6.4.4.")
|
|
149
|
|
150 (defvar nnimap-split-fancy nil
|
|
151 "Like `nnmail-split-fancy', which see.")
|
|
152
|
|
153 ;; Authorization / Privacy variables
|
|
154
|
|
155 (defvoo nnimap-auth-method nil
|
|
156 "Obsolete.")
|
|
157
|
|
158 (defvoo nnimap-stream nil
|
|
159 "How nnimap will connect to the server.
|
|
160
|
|
161 The default, nil, will try to use the \"best\" method the server can
|
|
162 handle.
|
|
163
|
|
164 Change this if
|
|
165
|
|
166 1) you want to connect with SSL. The SSL integration with IMAP is
|
|
167 brain-dead so you'll have to tell it specifically.
|
|
168
|
|
169 2) your server is more capable than your environment -- i.e. your
|
|
170 server accept Kerberos login's but you haven't installed the
|
|
171 `imtest' program or your machine isn't configured for Kerberos.
|
|
172
|
|
173 Possible choices: kerberos4, ssl, network")
|
|
174
|
|
175 (defvoo nnimap-authenticator nil
|
|
176 "How nnimap authenticate itself to the server.
|
|
177
|
|
178 The default, nil, will try to use the \"best\" method the server can
|
|
179 handle.
|
|
180
|
|
181 There is only one reason for fiddling with this variable, and that is
|
|
182 if your server is more capable than your environment -- i.e. you
|
|
183 connect to a server that accept Kerberos login's but you haven't
|
|
184 installed the `imtest' program or your machine isn't configured for
|
|
185 Kerberos.
|
|
186
|
|
187 Possible choices: kerberos4, cram-md5, login, anonymous.")
|
|
188
|
|
189 (defvoo nnimap-directory (nnheader-concat gnus-directory "overview/")
|
|
190 "Directory to keep NOV cache files for nnimap groups.
|
|
191 See also `nnimap-nov-file-name'.")
|
|
192
|
|
193 (defvoo nnimap-nov-file-name "nnimap."
|
|
194 "NOV cache base filename.
|
|
195 The group name and `nnimap-nov-file-name-suffix' will be appended. A
|
|
196 typical complete file name would be
|
|
197 ~/News/overview/nnimap.pdc.INBOX.ding.nov, or
|
|
198 ~/News/overview/nnimap/pdc/INBOX/ding/nov if
|
|
199 `nnmail-use-long-file-names' is nil")
|
|
200
|
|
201 (defvoo nnimap-nov-file-name-suffix ".novcache"
|
|
202 "Suffix for NOV cache base filename.")
|
|
203
|
|
204 (defvoo nnimap-nov-is-evil nil
|
|
205 "If non-nil, nnimap will never generate or use a local nov database for this backend.
|
|
206 Using nov databases will speed up header fetching considerably.
|
|
207 Unlike other backends, you do not need to take special care if you
|
|
208 flip this variable.")
|
|
209
|
|
210 (defvoo nnimap-expunge-on-close 'always ; 'ask, 'never
|
|
211 "Whether to expunge a group when it is closed.
|
|
212 When a IMAP group with articles marked for deletion is closed, this
|
|
213 variable determine if nnimap should actually remove the articles or
|
|
214 not.
|
|
215
|
|
216 If always, nnimap always perform a expunge when closing the group.
|
|
217 If never, nnimap never expunges articles marked for deletion.
|
|
218 If ask, nnimap will ask you if you wish to expunge marked articles.
|
|
219
|
|
220 When setting this variable to `never', you can only expunge articles
|
|
221 by using `G x' (gnus-group-nnimap-expunge) from the Group buffer.")
|
|
222
|
|
223 (defvoo nnimap-list-pattern "*"
|
|
224 "A string LIMIT or list of strings with mailbox wildcards used to limit available groups.
|
|
225 See below for available wildcards.
|
|
226
|
|
227 The LIMIT string can be a cons cell (REFERENCE . LIMIT), where
|
|
228 REFERENCE will be passed as the first parameter to LIST/LSUB. The
|
|
229 semantics of this are server specific, on the University of Washington
|
|
230 server you can specify a directory.
|
|
231
|
|
232 Example:
|
|
233 '(\"INBOX\" \"mail/*\" (\"~friend/mail/\" . \"list/*\"))
|
|
234
|
|
235 There are two wildcards * and %. * matches everything, % matches
|
|
236 everything in the current hierarchy.")
|
|
237
|
|
238 (defvoo nnimap-news-groups nil
|
|
239 "IMAP support a news-like mode, also known as bulletin board mode, where replies is sent via IMAP instead of SMTP.
|
|
240
|
|
241 This variable should contain a regexp matching groups where you wish
|
|
242 replies to be stored to the mailbox directly.
|
|
243
|
|
244 Example:
|
|
245 '(\"^[^I][^N][^B][^O][^X].*$\")
|
|
246
|
|
247 This will match all groups not beginning with \"INBOX\".
|
|
248
|
|
249 Note that there is nothing technically different between mail-like and
|
|
250 news-like mailboxes. If you wish to have a group with todo items or
|
|
251 similar which you wouldn't want to set up a mailing list for, you can
|
|
252 use this to make replies go directly to the group.")
|
|
253
|
|
254 (defvoo nnimap-server-address nil
|
|
255 "Obsolete. Use `nnimap-address'.")
|
|
256
|
|
257 (defcustom nnimap-authinfo-file "~/.authinfo"
|
|
258 "Authorization information for IMAP servers. In .netrc format."
|
|
259 :type
|
|
260 '(choice file
|
|
261 (repeat :tag "Entries"
|
|
262 :menu-tag "Inline"
|
|
263 (list :format "%v"
|
|
264 :value ("" ("login" . "") ("password" . ""))
|
|
265 (string :tag "Host")
|
|
266 (checklist :inline t
|
|
267 (cons :format "%v"
|
|
268 (const :format "" "login")
|
|
269 (string :format "Login: %v"))
|
|
270 (cons :format "%v"
|
|
271 (const :format "" "password")
|
|
272 (string :format "Password: %v")))))))
|
|
273
|
|
274 (defcustom nnimap-prune-cache t
|
|
275 "If non-nil, nnimap check whether articles still exist on server before using data stored in NOV cache."
|
|
276 :type 'boolean)
|
|
277
|
|
278 (defvar nnimap-request-list-method 'imap-mailbox-list
|
|
279 "Method to use to request a list of all folders from the server.
|
|
280 If this is 'imap-mailbox-lsub, then use a server-side subscription list to
|
|
281 restrict visible folders.")
|
|
282
|
|
283 ;; Internal variables:
|
|
284
|
|
285 (defvar nnimap-debug nil
|
|
286 "Name of buffer to record debugging info.
|
|
287 For example: (setq nnimap-debug \"*nnimap-debug*\")")
|
|
288 (defvar nnimap-current-move-server nil)
|
|
289 (defvar nnimap-current-move-group nil)
|
|
290 (defvar nnimap-current-move-article nil)
|
|
291 (defvar nnimap-length)
|
|
292 (defvar nnimap-progress-chars '(?| ?/ ?- ?\\))
|
|
293 (defvar nnimap-progress-how-often 20)
|
|
294 (defvar nnimap-counter)
|
|
295 (defvar nnimap-callback-callback-function nil
|
|
296 "Gnus callback the nnimap asynchronous callback should call.")
|
|
297 (defvar nnimap-callback-buffer nil
|
|
298 "Which buffer the asynchronous article prefetch callback should work in.")
|
|
299 (defvar nnimap-server-buffer-alist nil) ;; Map server name to buffers.
|
|
300 (defvar nnimap-current-server nil) ;; Current server
|
|
301 (defvar nnimap-server-buffer nil) ;; Current servers' buffer
|
|
302
|
|
303
|
|
304
|
|
305 (nnoo-define-basics nnimap)
|
|
306
|
|
307 ;; Utility functions:
|
|
308
|
|
309 (defsubst nnimap-get-server-buffer (server)
|
|
310 "Return buffer for SERVER, if nil use current server."
|
|
311 (cadr (assoc (or server nnimap-current-server) nnimap-server-buffer-alist)))
|
|
312
|
|
313 (defun nnimap-possibly-change-server (server)
|
|
314 "Return buffer for SERVER, changing the current server as a side-effect.
|
|
315 If SERVER is nil, uses the current server."
|
|
316 (setq nnimap-current-server (or server nnimap-current-server)
|
|
317 nnimap-server-buffer (nnimap-get-server-buffer nnimap-current-server)))
|
|
318
|
|
319 (defun nnimap-verify-uidvalidity (group server)
|
|
320 "Verify stored uidvalidity match current one in GROUP on SERVER."
|
|
321 (let* ((gnusgroup (gnus-group-prefixed-name
|
|
322 group (gnus-server-to-method
|
|
323 (format "nnimap:%s" server))))
|
|
324 (new-uidvalidity (imap-mailbox-get 'uidvalidity))
|
|
325 (old-uidvalidity (gnus-group-get-parameter gnusgroup 'uidvalidity)))
|
|
326 (if old-uidvalidity
|
|
327 (if (not (equal old-uidvalidity new-uidvalidity))
|
|
328 nil ;; uidvalidity clash
|
|
329 (gnus-group-set-parameter gnusgroup 'uidvalidity new-uidvalidity)
|
|
330 t)
|
|
331 (gnus-group-add-parameter gnusgroup (cons 'uidvalidity new-uidvalidity))
|
|
332 t)))
|
|
333
|
|
334 (defun nnimap-before-find-minmax-bugworkaround ()
|
|
335 "Function called before iterating through mailboxes with
|
|
336 `nnimap-find-minmax-uid'."
|
|
337 ;; XXX this is for UoW imapd problem, it doesn't notice new mail in
|
|
338 ;; currently selected mailbox without a re-select/examine.
|
|
339 (or (null (imap-current-mailbox nnimap-server-buffer))
|
|
340 (imap-mailbox-unselect nnimap-server-buffer)))
|
|
341
|
|
342 (defun nnimap-find-minmax-uid (group &optional examine)
|
|
343 "Find lowest and highest active article nummber in GROUP.
|
|
344 If EXAMINE is non-nil the group is selected read-only."
|
|
345 (with-current-buffer nnimap-server-buffer
|
|
346 (when (imap-mailbox-select group examine)
|
|
347 (let (minuid maxuid)
|
|
348 (when (> (imap-mailbox-get 'exists) 0)
|
|
349 (imap-fetch "1,*" "UID" nil 'nouidfetch)
|
|
350 (imap-message-map (lambda (uid Uid)
|
|
351 (setq minuid (if minuid (min minuid uid) uid)
|
|
352 maxuid (if maxuid (max maxuid uid) uid)))
|
|
353 'UID))
|
|
354 (list (imap-mailbox-get 'exists) minuid maxuid)))))
|
|
355
|
|
356 (defun nnimap-possibly-change-group (group &optional server)
|
|
357 "Make GROUP the current group, and SERVER the current server."
|
|
358 (when (nnimap-possibly-change-server server)
|
|
359 (with-current-buffer nnimap-server-buffer
|
|
360 (if (or (null group) (imap-current-mailbox-p group))
|
|
361 imap-current-mailbox
|
|
362 (if (imap-mailbox-select group)
|
|
363 (if (or (nnimap-verify-uidvalidity
|
|
364 group (or server nnimap-current-server))
|
|
365 (zerop (imap-mailbox-get 'exists group))
|
|
366 (yes-or-no-p
|
|
367 (format
|
|
368 "nnimap: Group %s is not uidvalid. Continue? " group)))
|
|
369 imap-current-mailbox
|
|
370 (imap-mailbox-unselect)
|
|
371 (error "nnimap: Group %s is not uid-valid." group))
|
|
372 (nnheader-report 'nnimap (imap-error-text)))))))
|
|
373
|
|
374 (defun nnimap-replace-whitespace (string)
|
|
375 "Return STRING with all whitespace replaced with space."
|
|
376 (when string
|
|
377 (while (string-match "[\r\n\t]+" string)
|
|
378 (setq string (replace-match " " t t string)))
|
|
379 string))
|
|
380
|
|
381 ;; Required backend functions
|
|
382
|
|
383 (defun nnimap-retrieve-headers-progress ()
|
|
384 "Hook to insert NOV line for current article into `nntp-server-buffer'."
|
|
385 (and (numberp nnmail-large-newsgroup)
|
|
386 (zerop (% (incf nnimap-counter) nnimap-progress-how-often))
|
|
387 (> nnimap-length nnmail-large-newsgroup)
|
|
388 (nnheader-message 6 "nnimap: Retrieving headers... %c"
|
|
389 (nth (/ (% nnimap-counter
|
|
390 (* (length nnimap-progress-chars)
|
|
391 nnimap-progress-how-often))
|
|
392 nnimap-progress-how-often)
|
|
393 nnimap-progress-chars)))
|
|
394 (with-current-buffer nntp-server-buffer
|
|
395 (let (headers lines chars uid mbx)
|
|
396 (with-current-buffer nnimap-server-buffer
|
|
397 (setq uid imap-current-message
|
|
398 mbx imap-current-mailbox
|
|
399 headers (nnimap-demule
|
|
400 (if (imap-capability 'IMAP4rev1)
|
|
401 ;; xxx don't just use car? alist doesn't contain
|
|
402 ;; anything else now, but it might...
|
|
403 (nth 2 (car (imap-message-get uid 'BODYDETAIL)))
|
|
404 (imap-message-get uid 'RFC822.HEADER)))
|
|
405 lines (imap-body-lines (imap-message-body imap-current-message))
|
|
406 chars (imap-message-get imap-current-message 'RFC822.SIZE)))
|
|
407 (nnheader-insert-nov
|
|
408 (with-temp-buffer
|
|
409 (buffer-disable-undo)
|
|
410 (insert headers)
|
|
411 (nnheader-ms-strip-cr)
|
|
412 (nnheader-fold-continuation-lines)
|
|
413 (subst-char-in-region (point-min) (point-max) ?\t ? )
|
|
414 (let ((head (nnheader-parse-head 'naked)))
|
|
415 (mail-header-set-number head uid)
|
|
416 (mail-header-set-chars head chars)
|
|
417 (mail-header-set-lines head lines)
|
|
418 (mail-header-set-xref
|
|
419 head (format "%s %s:%d" (system-name) mbx uid))
|
|
420 head))))))
|
|
421
|
|
422 (defun nnimap-retrieve-which-headers (articles fetch-old)
|
|
423 "Get a range of articles to fetch based on ARTICLES and FETCH-OLD."
|
|
424 (with-current-buffer nnimap-server-buffer
|
|
425 (if (numberp (car-safe articles))
|
|
426 (imap-search
|
|
427 (concat "UID "
|
|
428 (imap-range-to-message-set
|
|
429 (gnus-compress-sequence
|
|
430 (append (gnus-uncompress-sequence
|
|
431 (and fetch-old
|
|
432 (cons (if (numberp fetch-old)
|
|
433 (max 1 (- (car articles) fetch-old))
|
|
434 1)
|
|
435 (1- (car articles)))))
|
|
436 articles)))))
|
|
437 (mapcar (lambda (msgid)
|
|
438 (imap-search
|
|
439 (format "HEADER Message-Id %s" msgid)))
|
|
440 articles))))
|
|
441
|
|
442 (defun nnimap-group-overview-filename (group server)
|
|
443 "Make pathname for GROUP on SERVER."
|
|
444 (let ((dir (file-name-as-directory (expand-file-name nnimap-directory)))
|
|
445 (file (nnheader-translate-file-chars
|
|
446 (concat nnimap-nov-file-name
|
|
447 (if (equal server "")
|
|
448 "unnamed"
|
|
449 server) "." group nnimap-nov-file-name-suffix) t)))
|
|
450 (if (or nnmail-use-long-file-names
|
|
451 (file-exists-p (concat dir file)))
|
|
452 (concat dir file)
|
|
453 (concat dir (mm-encode-coding-string
|
|
454 (nnheader-replace-chars-in-string file ?. ?/)
|
|
455 nnmail-pathname-coding-system)))))
|
|
456
|
|
457 (defun nnimap-retrieve-headers-from-file (group server)
|
|
458 (with-current-buffer nntp-server-buffer
|
|
459 (let ((nov (nnimap-group-overview-filename group server)))
|
|
460 (when (file-exists-p nov)
|
|
461 (mm-insert-file-contents nov)
|
|
462 (set-buffer-modified-p nil)
|
|
463 (let ((min (ignore-errors (goto-char (point-min))
|
|
464 (read (current-buffer))))
|
|
465 (max (ignore-errors (goto-char (point-max))
|
|
466 (forward-line -1)
|
|
467 (read (current-buffer)))))
|
|
468 (if (and (numberp min) (numberp max))
|
|
469 (cons min max)
|
|
470 ;; junk, remove it, it's saved later
|
|
471 (erase-buffer)
|
|
472 nil))))))
|
|
473
|
|
474 (defun nnimap-retrieve-headers-from-server (articles group server)
|
|
475 (with-current-buffer nnimap-server-buffer
|
|
476 (let ((imap-fetch-data-hook '(nnimap-retrieve-headers-progress))
|
|
477 (nnimap-length (gnus-range-length articles))
|
|
478 (nnimap-counter 0))
|
|
479 (imap-fetch (imap-range-to-message-set articles)
|
|
480 (concat "(UID RFC822.SIZE BODY "
|
|
481 (let ((headers
|
|
482 (append '(Subject From Date Message-Id
|
|
483 References In-Reply-To Xref)
|
|
484 (copy-sequence
|
|
485 nnmail-extra-headers))))
|
|
486 (if (imap-capability 'IMAP4rev1)
|
|
487 (format "BODY.PEEK[HEADER.FIELDS %s])" headers)
|
|
488 (format "RFC822.HEADER.LINES %s)" headers)))))
|
|
489 (and (numberp nnmail-large-newsgroup)
|
|
490 (> nnimap-length nnmail-large-newsgroup)
|
|
491 (nnheader-message 6 "nnimap: Retrieving headers...done")))))
|
|
492
|
|
493 (defun nnimap-use-nov-p (group server)
|
|
494 (or gnus-nov-is-evil nnimap-nov-is-evil
|
|
495 (unless (and (gnus-make-directory
|
|
496 (file-name-directory
|
|
497 (nnimap-group-overview-filename group server)))
|
|
498 (file-writable-p
|
|
499 (nnimap-group-overview-filename group server)))
|
|
500 (message "nnimap: Nov cache not writable, %s"
|
|
501 (nnimap-group-overview-filename group server)))))
|
|
502
|
|
503 (deffoo nnimap-retrieve-headers (articles &optional group server fetch-old)
|
|
504 (when (nnimap-possibly-change-group group server)
|
|
505 (with-current-buffer nntp-server-buffer
|
|
506 (erase-buffer)
|
|
507 (if (nnimap-use-nov-p group server)
|
|
508 (nnimap-retrieve-headers-from-server
|
|
509 (gnus-compress-sequence articles) group server)
|
|
510 (let (uids cached low high)
|
|
511 (when (setq uids (nnimap-retrieve-which-headers articles fetch-old)
|
|
512 low (car uids)
|
|
513 high (car (last uids)))
|
|
514 (if (setq cached (nnimap-retrieve-headers-from-file group server))
|
|
515 (progn
|
|
516 ;; fetch articles with uids before cache block
|
|
517 (when (< low (car cached))
|
|
518 (goto-char (point-min))
|
|
519 (nnimap-retrieve-headers-from-server
|
|
520 (cons low (1- (car cached))) group server))
|
|
521 ;; fetch articles with uids after cache block
|
|
522 (when (> high (cdr cached))
|
|
523 (goto-char (point-max))
|
|
524 (nnimap-retrieve-headers-from-server
|
|
525 (cons (1+ (cdr cached)) high) group server))
|
|
526 (when nnimap-prune-cache
|
|
527 ;; remove nov's for articles which has expired on server
|
|
528 (goto-char (point-min))
|
|
529 (dolist (uid (gnus-set-difference articles uids))
|
|
530 (when (re-search-forward (format "^%d\t" uid) nil t)
|
|
531 (gnus-delete-line)))))
|
|
532 ;; nothing cached, fetch whole range from server
|
|
533 (nnimap-retrieve-headers-from-server
|
|
534 (cons low high) group server))
|
|
535 (when (buffer-modified-p)
|
|
536 (nnmail-write-region
|
|
537 1 (point-max) (nnimap-group-overview-filename group server)
|
|
538 nil 'nomesg))
|
|
539 (nnheader-nov-delete-outside-range low high))))
|
|
540 'nov)))
|
|
541
|
|
542 (defun nnimap-open-connection (server)
|
|
543 (if (not (imap-open nnimap-address nnimap-server-port nnimap-stream
|
|
544 nnimap-authenticator nnimap-server-buffer))
|
|
545 (nnheader-report 'nnimap "Can't open connection to server %s" server)
|
|
546 (unless (or (imap-capability 'IMAP4 nnimap-server-buffer)
|
|
547 (imap-capability 'IMAP4rev1 nnimap-server-buffer))
|
|
548 (imap-close nnimap-server-buffer)
|
|
549 (nnheader-report 'nnimap "Server %s is not IMAP4 compliant" server))
|
|
550 (let* ((list (gnus-parse-netrc nnimap-authinfo-file))
|
|
551 (port (if nnimap-server-port
|
|
552 (int-to-string nnimap-server-port)
|
|
553 "imap"))
|
|
554 (alist (gnus-netrc-machine list (or nnimap-server-address
|
|
555 nnimap-address server)
|
|
556 port "imap"))
|
|
557 (user (gnus-netrc-get alist "login"))
|
|
558 (passwd (gnus-netrc-get alist "password")))
|
|
559 (if (imap-authenticate user passwd nnimap-server-buffer)
|
|
560 (prog1
|
|
561 (push (list server nnimap-server-buffer)
|
|
562 nnimap-server-buffer-alist)
|
|
563 (nnimap-possibly-change-server server))
|
|
564 (imap-close nnimap-server-buffer)
|
|
565 (kill-buffer nnimap-server-buffer)
|
|
566 (nnheader-report 'nnimap "Could not authenticate to %s" server)))))
|
|
567
|
|
568 (deffoo nnimap-open-server (server &optional defs)
|
|
569 (nnheader-init-server-buffer)
|
|
570 (if (nnimap-server-opened server)
|
|
571 t
|
|
572 (unless (assq 'nnimap-server-buffer defs)
|
|
573 (push (list 'nnimap-server-buffer (concat " *nnimap* " server)) defs))
|
|
574 ;; translate `nnimap-server-address' to `nnimap-address' in defs
|
|
575 ;; for people that configured nnimap with a very old version
|
|
576 (unless (assq 'nnimap-address defs)
|
|
577 (if (assq 'nnimap-server-address defs)
|
|
578 (push (list 'nnimap-address
|
|
579 (cadr (assq 'nnimap-server-address defs))) defs)
|
|
580 (push (list 'nnimap-address server) defs)))
|
|
581 (nnoo-change-server 'nnimap server defs)
|
|
582 (with-current-buffer (get-buffer-create nnimap-server-buffer)
|
|
583 (nnoo-change-server 'nnimap server defs))
|
|
584 (or (and nnimap-server-buffer
|
|
585 (imap-opened nnimap-server-buffer))
|
|
586 (nnimap-open-connection server))))
|
|
587
|
|
588 (deffoo nnimap-server-opened (&optional server)
|
|
589 "Whether SERVER is opened.
|
|
590 If SERVER is the current virtual server, and the connection to the
|
|
591 physical server is alive, this function return a non-nil value. If
|
|
592 SERVER is nil, it is treated as the current server."
|
|
593 ;; clean up autologouts??
|
|
594 (and (or server nnimap-current-server)
|
|
595 (nnoo-server-opened 'nnimap (or server nnimap-current-server))
|
|
596 (imap-opened (nnimap-get-server-buffer server))))
|
|
597
|
|
598 (deffoo nnimap-close-server (&optional server)
|
|
599 "Close connection to server and free all resources connected to it.
|
|
600 Return nil if the server couldn't be closed for some reason."
|
|
601 (let ((server (or server nnimap-current-server)))
|
|
602 (when (or (nnimap-server-opened server)
|
|
603 (imap-opened (nnimap-get-server-buffer server)))
|
|
604 (imap-close (nnimap-get-server-buffer server))
|
|
605 (kill-buffer (nnimap-get-server-buffer server))
|
|
606 (setq nnimap-server-buffer nil
|
|
607 nnimap-current-server nil
|
|
608 nnimap-server-buffer-alist
|
|
609 (delq server nnimap-server-buffer-alist)))
|
|
610 (nnoo-close-server 'nnimap server)))
|
|
611
|
|
612 (deffoo nnimap-request-close ()
|
|
613 "Close connection to all servers and free all resources that the backend have reserved.
|
|
614 All buffers that have been created by that
|
|
615 backend should be killed. (Not the nntp-server-buffer, though.) This
|
|
616 function is generally only called when Gnus is shutting down."
|
|
617 (mapcar (lambda (server) (nnimap-close-server (car server)))
|
|
618 nnimap-server-buffer-alist)
|
|
619 (setq nnimap-server-buffer-alist nil))
|
|
620
|
|
621 (deffoo nnimap-status-message (&optional server)
|
|
622 "This function returns the last error message from server."
|
|
623 (when (nnimap-possibly-change-server server)
|
|
624 (nnoo-status-message 'nnimap server)))
|
|
625
|
|
626 (defun nnimap-demule (string)
|
|
627 (funcall (if (and (fboundp 'string-as-multibyte)
|
|
628 (subrp (symbol-function 'string-as-multibyte)))
|
|
629 'string-as-multibyte
|
|
630 'identity)
|
|
631 (or string "")))
|
|
632
|
|
633 (defun nnimap-callback ()
|
|
634 (remove-hook 'imap-fetch-data-hook 'nnimap-callback)
|
|
635 (with-current-buffer nnimap-callback-buffer
|
|
636 (insert
|
|
637 (with-current-buffer nnimap-server-buffer
|
|
638 (nnimap-demule
|
|
639 (if (imap-capability 'IMAP4rev1)
|
|
640 ;; xxx don't just use car? alist doesn't contain
|
|
641 ;; anything else now, but it might...
|
|
642 (nth 2 (car (imap-message-get (imap-current-message) 'BODYDETAIL)))
|
|
643 (imap-message-get (imap-current-message) 'RFC822)))))
|
|
644 (nnheader-ms-strip-cr)
|
|
645 (funcall nnimap-callback-callback-function t)))
|
|
646
|
|
647 (defun nnimap-request-article-part (article part prop &optional
|
|
648 group server to-buffer detail)
|
|
649 (when (nnimap-possibly-change-group group server)
|
|
650 (let ((article (if (stringp article)
|
|
651 (car-safe (imap-search
|
|
652 (format "HEADER Message-Id %s" article)
|
|
653 nnimap-server-buffer))
|
|
654 article)))
|
|
655 (when article
|
|
656 (gnus-message 10 "nnimap: Fetching (part of) article %d..." article)
|
|
657 (if (not nnheader-callback-function)
|
|
658 (with-current-buffer (or to-buffer nntp-server-buffer)
|
|
659 (erase-buffer)
|
|
660 (let ((data (imap-fetch article part prop nil
|
|
661 nnimap-server-buffer)))
|
|
662 (insert (nnimap-demule (if detail
|
|
663 (nth 2 (car data))
|
|
664 data))))
|
|
665 (nnheader-ms-strip-cr)
|
|
666 (gnus-message 10 "nnimap: Fetching (part of) article %d...done"
|
|
667 article)
|
|
668 (if (bobp)
|
|
669 (nnheader-report 'nnimap "No such article: %s"
|
|
670 (imap-error-text nnimap-server-buffer))
|
|
671 (cons group article)))
|
|
672 (add-hook 'imap-fetch-data-hook 'nnimap-callback)
|
|
673 (setq nnimap-callback-callback-function nnheader-callback-function
|
|
674 nnimap-callback-buffer nntp-server-buffer)
|
|
675 (imap-fetch-asynch article part nil nnimap-server-buffer)
|
|
676 (cons group article))))))
|
|
677
|
|
678 (deffoo nnimap-asynchronous-p ()
|
|
679 t)
|
|
680
|
|
681 (deffoo nnimap-request-article (article &optional group server to-buffer)
|
|
682 (if (imap-capability 'IMAP4rev1 nnimap-server-buffer)
|
|
683 (nnimap-request-article-part
|
|
684 article "BODY.PEEK[]" 'BODYDETAIL group server to-buffer 'detail)
|
|
685 (nnimap-request-article-part
|
|
686 article "RFC822.PEEK" 'RFC822 group server to-buffer)))
|
|
687
|
|
688 (deffoo nnimap-request-head (article &optional group server to-buffer)
|
|
689 (if (imap-capability 'IMAP4rev1 nnimap-server-buffer)
|
|
690 (nnimap-request-article-part
|
|
691 article "BODY.PEEK[HEADER]" 'BODYDETAIL group server to-buffer 'detail)
|
|
692 (nnimap-request-article-part
|
|
693 article "RFC822.HEADER" 'RFC822.HEADER group server to-buffer)))
|
|
694
|
|
695 (deffoo nnimap-request-body (article &optional group server to-buffer)
|
|
696 (if (imap-capability 'IMAP4rev1 nnimap-server-buffer)
|
|
697 (nnimap-request-article-part
|
|
698 article "BODY.PEEK[TEXT]" 'BODYDETAIL group server to-buffer 'detail)
|
|
699 (nnimap-request-article-part
|
|
700 article "RFC822.TEXT.PEEK" 'RFC822.TEXT group server to-buffer)))
|
|
701
|
|
702 (deffoo nnimap-request-group (group &optional server fast)
|
|
703 (nnimap-request-update-info-internal
|
|
704 group
|
|
705 (gnus-get-info (gnus-group-prefixed-name
|
|
706 group (gnus-server-to-method (format "nnimap:%s" server))))
|
|
707 server)
|
|
708 (when (nnimap-possibly-change-group group server)
|
|
709 (nnimap-before-find-minmax-bugworkaround)
|
|
710 (let (info)
|
|
711 (cond (fast group)
|
|
712 ((null (setq info (nnimap-find-minmax-uid group t)))
|
|
713 (nnheader-report 'nnimap "Could not get active info for %s"
|
|
714 group))
|
|
715 (t
|
|
716 (nnheader-insert "211 %d %d %d %s\n" (or (nth 0 info) 0)
|
|
717 (max 1 (or (nth 1 info) 1))
|
|
718 (or (nth 2 info) 0) group)
|
|
719 (nnheader-report 'nnimap "Group %s selected" group)
|
|
720 t)))))
|
|
721
|
|
722 (defun nnimap-close-group (group &optional server)
|
|
723 (with-current-buffer nnimap-server-buffer
|
|
724 (when (and (imap-opened)
|
|
725 (nnimap-possibly-change-group group server))
|
|
726 (case nnimap-expunge-on-close
|
|
727 ('always (imap-mailbox-expunge)
|
|
728 (imap-mailbox-close))
|
|
729 ('ask (if (and (imap-search "DELETED")
|
|
730 (gnus-y-or-n-p (format
|
|
731 "Expunge articles in group `%s'? "
|
|
732 imap-current-mailbox)))
|
|
733 (progn (imap-mailbox-expunge)
|
|
734 (imap-mailbox-close))
|
|
735 (imap-mailbox-unselect)))
|
|
736 (t (imap-mailbox-unselect)))
|
|
737 (not imap-current-mailbox))))
|
|
738
|
|
739 (defun nnimap-pattern-to-list-arguments (pattern)
|
|
740 (mapcar (lambda (p)
|
|
741 (cons (car-safe p) (or (cdr-safe p) p)))
|
|
742 (if (and (listp pattern)
|
|
743 (listp (cdr pattern)))
|
|
744 pattern
|
|
745 (list pattern))))
|
|
746
|
|
747 (deffoo nnimap-request-list (&optional server)
|
|
748 (when (nnimap-possibly-change-server server)
|
|
749 (with-current-buffer nntp-server-buffer
|
|
750 (erase-buffer))
|
|
751 (gnus-message 5 "nnimap: Generating active list%s..."
|
|
752 (if (> (length server) 0) (concat " for " server) ""))
|
|
753 (nnimap-before-find-minmax-bugworkaround)
|
|
754 (with-current-buffer nnimap-server-buffer
|
|
755 (dolist (pattern (nnimap-pattern-to-list-arguments nnimap-list-pattern))
|
|
756 (dolist (mbx (funcall nnimap-request-list-method
|
|
757 (cdr pattern) (car pattern)))
|
|
758 (or (member "\\NoSelect" (imap-mailbox-get 'list-flags mbx))
|
|
759 (let ((info (nnimap-find-minmax-uid mbx 'examine)))
|
|
760 (when info
|
|
761 (with-current-buffer nntp-server-buffer
|
|
762 (insert (format "\"%s\" %d %d y\n"
|
|
763 mbx (or (nth 2 info) 0)
|
|
764 (max 1 (or (nth 1 info) 1)))))))))))
|
|
765 (gnus-message 5 "nnimap: Generating active list%s...done"
|
|
766 (if (> (length server) 0) (concat " for " server) ""))
|
|
767 t))
|
|
768
|
|
769 (deffoo nnimap-request-post (&optional server)
|
|
770 (let ((success t))
|
|
771 (dolist (mbx (message-unquote-tokens
|
|
772 (message-tokenize-header
|
|
773 (message-fetch-field "Newsgroups") ", ")) success)
|
|
774 (let ((to-newsgroup (gnus-group-prefixed-name mbx gnus-command-method)))
|
|
775 (or (gnus-active to-newsgroup)
|
|
776 (gnus-activate-group to-newsgroup)
|
|
777 (if (gnus-y-or-n-p (format "No such group: %s. Create it? "
|
|
778 to-newsgroup))
|
|
779 (or (and (gnus-request-create-group
|
|
780 to-newsgroup gnus-command-method)
|
|
781 (gnus-activate-group to-newsgroup nil nil
|
|
782 gnus-command-method))
|
|
783 (error "Couldn't create group %s" to-newsgroup)))
|
|
784 (error "No such group: %s" to-newsgroup))
|
|
785 (unless (nnimap-request-accept-article mbx (nth 1 gnus-command-method))
|
|
786 (setq success nil))))))
|
|
787
|
|
788 ;; Optional backend functions
|
|
789
|
|
790 (deffoo nnimap-retrieve-groups (groups &optional server)
|
|
791 (when (nnimap-possibly-change-server server)
|
|
792 (gnus-message 5 "nnimap: Checking mailboxes...")
|
|
793 (with-current-buffer nntp-server-buffer
|
|
794 (erase-buffer)
|
|
795 (nnimap-before-find-minmax-bugworkaround)
|
|
796 (dolist (group groups)
|
|
797 (gnus-message 7 "nnimap: Checking mailbox %s" group)
|
|
798 (or (member "\\NoSelect"
|
|
799 (imap-mailbox-get 'list-flags group nnimap-server-buffer))
|
|
800 (let ((info (nnimap-find-minmax-uid group 'examine)))
|
|
801 (insert (format "\"%s\" %d %d y\n" group
|
|
802 (or (nth 2 info) 0)
|
|
803 (max 1 (or (nth 1 info) 1))))))))
|
|
804 (gnus-message 5 "nnimap: Checking mailboxes...done")
|
|
805 'active))
|
|
806
|
|
807 (deffoo nnimap-request-update-info-internal (group info &optional server)
|
|
808 (when (nnimap-possibly-change-group group server)
|
|
809 (when info;; xxx what does this mean? should we create a info?
|
|
810 (with-current-buffer nnimap-server-buffer
|
|
811 (gnus-message 5 "nnimap: Updating info for %s..."
|
|
812 (gnus-info-group info))
|
|
813
|
|
814 (when (nnimap-mark-permanent-p 'read)
|
|
815 (let (seen unseen)
|
|
816 ;; read info could contain articles marked unread by other
|
|
817 ;; imap clients! we correct this
|
|
818 (setq seen (gnus-uncompress-range (gnus-info-read info))
|
|
819 unseen (imap-search "UNSEEN UNDELETED")
|
|
820 seen (gnus-set-difference seen unseen)
|
|
821 ;; seen might lack articles marked as read by other
|
|
822 ;; imap clients! we correct this
|
|
823 seen (append seen (imap-search "SEEN"))
|
|
824 ;; remove dupes
|
|
825 seen (sort seen '<)
|
|
826 seen (gnus-compress-sequence seen t)
|
|
827 ;; we can't return '(1) since this isn't a "list of ranges",
|
|
828 ;; and we can't return '((1)) since g-list-of-unread-articles
|
|
829 ;; is buggy so we return '((1 . 1)).
|
|
830 seen (if (and (integerp (car seen))
|
|
831 (null (cdr seen)))
|
|
832 (list (cons (car seen) (car seen)))
|
|
833 seen))
|
|
834 (gnus-info-set-read info seen)))
|
|
835
|
|
836 (mapcar (lambda (pred)
|
|
837 (when (and (nnimap-mark-permanent-p (cdr pred))
|
|
838 (member (nnimap-mark-to-flag (cdr pred))
|
|
839 (imap-mailbox-get 'flags)))
|
|
840 (gnus-info-set-marks
|
|
841 info
|
|
842 (nnimap-update-alist-soft
|
|
843 (cdr pred)
|
|
844 (gnus-compress-sequence
|
|
845 (imap-search (nnimap-mark-to-predicate (cdr pred))))
|
|
846 (gnus-info-marks info))
|
|
847 t)))
|
|
848 gnus-article-mark-lists)
|
|
849
|
|
850 ;; nnimap mark dormant article as ticked too (for other clients)
|
|
851 ;; so we remove that mark for gnus since we support dormant
|
|
852 (gnus-info-set-marks
|
|
853 info
|
|
854 (nnimap-update-alist-soft
|
|
855 'tick
|
|
856 (gnus-remove-from-range
|
|
857 (cdr-safe (assoc 'tick (gnus-info-marks info)))
|
|
858 (cdr-safe (assoc 'dormant (gnus-info-marks info))))
|
|
859 (gnus-info-marks info))
|
|
860 t)
|
|
861
|
|
862 (gnus-message 5 "nnimap: Updating info for %s...done"
|
|
863 (gnus-info-group info))
|
|
864
|
|
865 info))))
|
|
866
|
|
867 (deffoo nnimap-request-type (group &optional article)
|
|
868 (if (and nnimap-news-groups (string-match nnimap-news-groups group))
|
|
869 'news
|
|
870 'mail))
|
|
871
|
|
872 (deffoo nnimap-request-set-mark (group actions &optional server)
|
|
873 (when (nnimap-possibly-change-group group server)
|
|
874 (with-current-buffer nnimap-server-buffer
|
|
875 (let (action)
|
|
876 (gnus-message 7 "nnimap: Setting marks in %s..." group)
|
|
877 (while (setq action (pop actions))
|
|
878 (let ((range (nth 0 action))
|
|
879 (what (nth 1 action))
|
|
880 (cmdmarks (nth 2 action))
|
|
881 marks)
|
|
882 ;; cache flags are pointless on the server
|
|
883 (setq cmdmarks (delq 'cache cmdmarks))
|
|
884 ;; flag dormant articles as ticked
|
|
885 (if (memq 'dormant cmdmarks)
|
|
886 (setq cmdmarks (cons 'tick cmdmarks)))
|
|
887 ;; remove stuff we are forbidden to store
|
|
888 (mapcar (lambda (mark)
|
|
889 (if (imap-message-flag-permanent-p
|
|
890 (nnimap-mark-to-flag mark))
|
|
891 (setq marks (cons mark marks))))
|
|
892 cmdmarks)
|
|
893 (when (and range marks)
|
|
894 (cond ((eq what 'del)
|
|
895 (imap-message-flags-del
|
|
896 (imap-range-to-message-set range)
|
|
897 (nnimap-mark-to-flag marks nil t)))
|
|
898 ((eq what 'add)
|
|
899 (imap-message-flags-add
|
|
900 (imap-range-to-message-set range)
|
|
901 (nnimap-mark-to-flag marks nil t)))
|
|
902 ((eq what 'set)
|
|
903 (imap-message-flags-set
|
|
904 (imap-range-to-message-set range)
|
|
905 (nnimap-mark-to-flag marks nil t)))))))
|
|
906 (gnus-message 7 "nnimap: Setting marks in %s...done" group))))
|
|
907 nil)
|
|
908
|
|
909 (defun nnimap-split-fancy ()
|
|
910 "Like nnmail-split-fancy, but uses nnimap-split-fancy."
|
|
911 (let ((nnmail-split-fancy nnimap-split-fancy))
|
|
912 (nnmail-split-fancy)))
|
|
913
|
|
914 (defun nnimap-split-to-groups (rules)
|
|
915 ;; tries to match all rules in nnimap-split-rule against content of
|
|
916 ;; nntp-server-buffer, returns a list of groups that matched.
|
|
917 (with-current-buffer nntp-server-buffer
|
|
918 ;; Fold continuation lines.
|
|
919 (goto-char (point-min))
|
|
920 (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
|
|
921 (replace-match " " t t))
|
|
922 (if (functionp rules)
|
|
923 (funcall rules)
|
|
924 (let (to-groups regrepp)
|
|
925 (catch 'split-done
|
|
926 (dolist (rule rules to-groups)
|
|
927 (let ((group (car rule))
|
|
928 (regexp (cadr rule)))
|
|
929 (goto-char (point-min))
|
|
930 (when (and (if (stringp regexp)
|
|
931 (progn
|
|
932 (setq regrepp (string-match "\\\\[0-9&]" group))
|
|
933 (re-search-forward regexp nil t))
|
|
934 (funcall regexp group))
|
|
935 ;; Don't enter the article into the same group twice.
|
|
936 (not (assoc group to-groups)))
|
|
937 (push (if regrepp
|
|
938 (nnmail-expand-newtext group)
|
|
939 group)
|
|
940 to-groups)
|
|
941 (or nnimap-split-crosspost
|
|
942 (throw 'split-done to-groups))))))))))
|
|
943
|
|
944 (defun nnimap-assoc-match (key alist)
|
|
945 (let (element)
|
|
946 (while (and alist (not element))
|
|
947 (if (string-match (car (car alist)) key)
|
|
948 (setq element (car alist)))
|
|
949 (setq alist (cdr alist)))
|
|
950 element))
|
|
951
|
|
952 (defun nnimap-split-find-rule (server inbox)
|
|
953 (if (and (listp nnimap-split-rule) (listp (car nnimap-split-rule))
|
|
954 (list (cdar nnimap-split-rule)) (listp (cadar nnimap-split-rule)))
|
|
955 ;; extended format
|
|
956 (cadr (nnimap-assoc-match inbox (cdr (nnimap-assoc-match
|
|
957 server nnimap-split-rule))))
|
|
958 nnimap-split-rule))
|
|
959
|
|
960 (defun nnimap-split-find-inbox (server)
|
|
961 (if (listp nnimap-split-inbox)
|
|
962 nnimap-split-inbox
|
|
963 (list nnimap-split-inbox)))
|
|
964
|
|
965 (defun nnimap-split-articles (&optional group server)
|
|
966 (when (nnimap-possibly-change-server server)
|
|
967 (with-current-buffer nnimap-server-buffer
|
|
968 (let (rule inbox removeorig (inboxes (nnimap-split-find-inbox server)))
|
|
969 ;; iterate over inboxes
|
|
970 (while (and (setq inbox (pop inboxes))
|
|
971 (nnimap-possibly-change-group inbox));; SELECT
|
|
972 ;; find split rule for this server / inbox
|
|
973 (when (setq rule (nnimap-split-find-rule server inbox))
|
|
974 ;; iterate over articles
|
|
975 (dolist (article (imap-search nnimap-split-predicate))
|
|
976 (when (nnimap-request-head article)
|
|
977 ;; copy article to right group(s)
|
|
978 (setq removeorig nil)
|
|
979 (dolist (to-group (nnimap-split-to-groups rule))
|
|
980 (if (imap-message-copy (number-to-string article)
|
|
981 to-group nil 'nocopyuid)
|
|
982 (progn
|
|
983 (message "IMAP split moved %s:%s:%d to %s" server inbox
|
|
984 article to-group)
|
|
985 (setq removeorig t)
|
|
986 ;; Add the group-art list to the history list.
|
|
987 (push (list (cons to-group 0)) nnmail-split-history))
|
|
988 (message "IMAP split failed to move %s:%s:%d to %s" server
|
|
989 inbox article to-group)))
|
|
990 ;; remove article if it was successfully copied somewhere
|
|
991 (and removeorig
|
|
992 (imap-message-flags-add (format "%d" article)
|
|
993 "\\Seen \\Deleted")))))
|
|
994 (when (imap-mailbox-select inbox);; just in case
|
|
995 ;; todo: UID EXPUNGE (if available) to remove splitted articles
|
|
996 (imap-mailbox-expunge)
|
|
997 (imap-mailbox-close)))
|
|
998 t))))
|
|
999
|
|
1000 (deffoo nnimap-request-scan (&optional group server)
|
|
1001 (nnimap-split-articles group server))
|
|
1002
|
|
1003 (deffoo nnimap-request-newgroups (date &optional server)
|
|
1004 (when (nnimap-possibly-change-server server)
|
|
1005 (with-current-buffer nntp-server-buffer
|
|
1006 (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s..."
|
|
1007 (if (> (length server) 0) " on " "") server)
|
|
1008 (erase-buffer)
|
|
1009 (nnimap-before-find-minmax-bugworkaround)
|
|
1010 (dolist (pattern (nnimap-pattern-to-list-arguments
|
|
1011 nnimap-list-pattern))
|
|
1012 (dolist (mbx (imap-mailbox-lsub "*" (car pattern) nil
|
|
1013 nnimap-server-buffer))
|
|
1014 (or (catch 'found
|
|
1015 (dolist (mailbox (imap-mailbox-get 'list-flags mbx
|
|
1016 nnimap-server-buffer))
|
|
1017 (if (string= (downcase mailbox) "\\noselect")
|
|
1018 (throw 'found t)))
|
|
1019 nil)
|
|
1020 (let ((info (nnimap-find-minmax-uid mbx 'examine)))
|
|
1021 (when info
|
|
1022 (insert (format "\"%s\" %d %d y\n"
|
|
1023 mbx (or (nth 2 info) 0)
|
|
1024 (max 1 (or (nth 1 info) 1)))))))))
|
|
1025 (gnus-message 5 "nnimap: Listing subscribed mailboxes%s%s...done"
|
|
1026 (if (> (length server) 0) " on " "") server))
|
|
1027 t))
|
|
1028
|
|
1029 (deffoo nnimap-request-create-group (group &optional server args)
|
|
1030 (when (nnimap-possibly-change-server server)
|
|
1031 (or (imap-mailbox-status group 'uidvalidity nnimap-server-buffer)
|
|
1032 (imap-mailbox-create group nnimap-server-buffer))))
|
|
1033
|
|
1034 (defun nnimap-time-substract (time1 time2)
|
|
1035 "Return TIME for TIME1 - TIME2."
|
|
1036 (let* ((ms (- (car time1) (car time2)))
|
|
1037 (ls (- (nth 1 time1) (nth 1 time2))))
|
|
1038 (if (< ls 0)
|
|
1039 (list (- ms 1) (+ (expt 2 16) ls))
|
|
1040 (list ms ls))))
|
|
1041
|
|
1042 (defun nnimap-date-days-ago (daysago)
|
|
1043 "Return date, in format \"3-Aug-1998\", for DAYSAGO days ago."
|
|
1044 (let ((date (format-time-string "%d-%b-%Y"
|
|
1045 (nnimap-time-substract
|
|
1046 (current-time)
|
|
1047 (days-to-time daysago)))))
|
|
1048 (if (eq ?0 (string-to-char date))
|
|
1049 (substring date 1)
|
|
1050 date)))
|
|
1051
|
|
1052 (defun nnimap-request-expire-articles-progress ()
|
|
1053 (gnus-message 5 "nnimap: Marking article %d for deletion..."
|
|
1054 imap-current-message))
|
|
1055
|
|
1056 ;; Notice that we don't actually delete anything, we just mark them deleted.
|
|
1057 (deffoo nnimap-request-expire-articles (articles group &optional server force)
|
|
1058 (let ((artseq (gnus-compress-sequence articles)))
|
|
1059 (when (and artseq (nnimap-possibly-change-group group server))
|
|
1060 (with-current-buffer nnimap-server-buffer
|
|
1061 (if force
|
|
1062 (and (imap-message-flags-add
|
|
1063 (imap-range-to-message-set artseq) "\\Deleted")
|
|
1064 (setq articles nil))
|
|
1065 (let ((days (or (and nnmail-expiry-wait-function
|
|
1066 (funcall nnmail-expiry-wait-function group))
|
|
1067 nnmail-expiry-wait)))
|
|
1068 (cond ((eq days 'immediate)
|
|
1069 (and (imap-message-flags-add
|
|
1070 (imap-range-to-message-set artseq) "\\Deleted")
|
|
1071 (setq articles nil)))
|
|
1072 ((numberp days)
|
|
1073 (let ((oldarts (imap-search
|
|
1074 (format "UID %s NOT SINCE %s"
|
|
1075 (imap-range-to-message-set artseq)
|
|
1076 (nnimap-date-days-ago days))))
|
|
1077 (imap-fetch-data-hook
|
|
1078 '(nnimap-request-expire-articles-progress)))
|
|
1079 (and oldarts
|
|
1080 (imap-message-flags-add
|
|
1081 (imap-range-to-message-set
|
|
1082 (gnus-compress-sequence oldarts))
|
|
1083 "\\Deleted")
|
|
1084 (setq articles (gnus-set-difference
|
|
1085 articles oldarts)))))))))))
|
|
1086 ;; return articles not deleted
|
|
1087 articles)
|
|
1088
|
|
1089 (deffoo nnimap-request-move-article (article group server
|
|
1090 accept-form &optional last)
|
|
1091 (when (nnimap-possibly-change-server server)
|
|
1092 (save-excursion
|
|
1093 (let ((buf (get-buffer-create " *nnimap move*"))
|
|
1094 (nnimap-current-move-article article)
|
|
1095 (nnimap-current-move-group group)
|
|
1096 (nnimap-current-move-server nnimap-current-server)
|
|
1097 result)
|
|
1098 (and (nnimap-request-article article group server)
|
|
1099 (save-excursion
|
|
1100 (set-buffer buf)
|
|
1101 (buffer-disable-undo (current-buffer))
|
|
1102 (insert-buffer-substring nntp-server-buffer)
|
|
1103 (setq result (eval accept-form))
|
|
1104 (kill-buffer buf)
|
|
1105 result)
|
|
1106 (nnimap-request-expire-articles (list article) group server t))
|
|
1107 result))))
|
|
1108
|
|
1109 (deffoo nnimap-request-accept-article (group &optional server last)
|
|
1110 (when (nnimap-possibly-change-server server)
|
|
1111 (let (uid)
|
|
1112 (if (setq uid
|
|
1113 (if (string= nnimap-current-server nnimap-current-move-server)
|
|
1114 ;; moving article within same server, speed it up...
|
|
1115 (and (nnimap-possibly-change-group
|
|
1116 nnimap-current-move-group)
|
|
1117 (imap-message-copy (number-to-string
|
|
1118 nnimap-current-move-article)
|
|
1119 group 'dontcreate nil
|
|
1120 nnimap-server-buffer))
|
|
1121 ;; turn into rfc822 format (\r\n eol's)
|
|
1122 (with-current-buffer (current-buffer)
|
|
1123 (goto-char (point-min))
|
|
1124 (while (search-forward "\n" nil t)
|
|
1125 (replace-match "\r\n")))
|
|
1126 ;; this 'or' is for Cyrus server bug
|
|
1127 (or (null (imap-current-mailbox nnimap-server-buffer))
|
|
1128 (imap-mailbox-unselect nnimap-server-buffer))
|
|
1129 (imap-message-append group (current-buffer) nil nil
|
|
1130 nnimap-server-buffer)))
|
|
1131 (cons group (nth 1 uid))
|
|
1132 (nnheader-report 'nnimap (imap-error-text nnimap-server-buffer))))))
|
|
1133
|
|
1134 (deffoo nnimap-request-delete-group (group force &optional server)
|
|
1135 (when (nnimap-possibly-change-server server)
|
|
1136 (with-current-buffer nnimap-server-buffer
|
|
1137 (if force
|
|
1138 (or (null (imap-mailbox-status group 'uidvalidity))
|
|
1139 (imap-mailbox-delete group))
|
|
1140 ;; UNSUBSCRIBE?
|
|
1141 t))))
|
|
1142
|
|
1143 (deffoo nnimap-request-rename-group (group new-name &optional server)
|
|
1144 (when (nnimap-possibly-change-server server)
|
|
1145 (imap-mailbox-rename group new-name nnimap-server-buffer)))
|
|
1146
|
|
1147 (defun nnimap-expunge (mailbox server)
|
|
1148 (when (nnimap-possibly-change-group mailbox server)
|
|
1149 (imap-mailbox-expunge nnimap-server-buffer)))
|
|
1150
|
|
1151 (defun nnimap-acl-get (mailbox server)
|
|
1152 (when (nnimap-possibly-change-server server)
|
|
1153 (imap-mailbox-acl-get mailbox nnimap-server-buffer)))
|
|
1154
|
|
1155 (defun nnimap-acl-edit (mailbox method old-acls new-acls)
|
|
1156 (when (nnimap-possibly-change-server (cadr method))
|
|
1157 (unless (imap-capability 'ACL nnimap-server-buffer)
|
|
1158 (error "Your server does not support ACL editing"))
|
|
1159 (with-current-buffer nnimap-server-buffer
|
|
1160 ;; delete all removed identifiers
|
|
1161 (mapcar (lambda (old-acl)
|
|
1162 (unless (assoc (car old-acl) new-acls)
|
|
1163 (or (imap-mailbox-acl-delete (car old-acl) mailbox)
|
|
1164 (error "Can't delete ACL for %s" (car old-acl)))))
|
|
1165 old-acls)
|
|
1166 ;; set all changed acl's
|
|
1167 (mapcar (lambda (new-acl)
|
|
1168 (let ((new-rights (cdr new-acl))
|
|
1169 (old-rights (cdr (assoc (car new-acl) old-acls))))
|
|
1170 (unless (and old-rights new-rights
|
|
1171 (string= old-rights new-rights))
|
|
1172 (or (imap-mailbox-acl-set (car new-acl) new-rights mailbox)
|
|
1173 (error "Can't set ACL for %s to %s" (car new-acl)
|
|
1174 new-rights)))))
|
|
1175 new-acls)
|
|
1176 t)))
|
|
1177
|
|
1178
|
|
1179 ;;; Internal functions
|
|
1180
|
|
1181 ;;
|
|
1182 ;; This is confusing.
|
|
1183 ;;
|
|
1184 ;; mark => read, tick, draft, reply etc
|
|
1185 ;; flag => "\\Seen", "\\Flagged", "\\Draft", "gnus-expire" etc
|
|
1186 ;; predicate => "SEEN", "FLAGGED", "DRAFT", "KEYWORD gnus-expire" etc
|
|
1187 ;;
|
|
1188 ;; Mark should not really contain 'read since it's not a "mark" in the Gnus
|
|
1189 ;; world, but we cheat. Mark == gnus-article-mark-lists + '(read . read).
|
|
1190 ;;
|
|
1191
|
|
1192 (defconst nnimap-mark-to-predicate-alist
|
|
1193 (mapcar
|
|
1194 (lambda (pair) ; cdr is the mark
|
|
1195 (or (assoc (cdr pair)
|
|
1196 '((read . "SEEN")
|
|
1197 (tick . "FLAGGED")
|
|
1198 (draft . "DRAFT")
|
|
1199 (reply . "ANSWERED")))
|
|
1200 (cons (cdr pair)
|
|
1201 (format "KEYWORD gnus-%s" (symbol-name (cdr pair))))))
|
|
1202 (cons '(read . read) gnus-article-mark-lists)))
|
|
1203
|
|
1204 (defun nnimap-mark-to-predicate (pred)
|
|
1205 "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP predicate.
|
|
1206 This is a string such as \"SEEN\", \"FLAGGED\", \"KEYWORD gnus-expire\",
|
|
1207 to be used within a IMAP SEARCH query."
|
|
1208 (cdr (assq pred nnimap-mark-to-predicate-alist)))
|
|
1209
|
|
1210 (defconst nnimap-mark-to-flag-alist
|
|
1211 (mapcar
|
|
1212 (lambda (pair)
|
|
1213 (or (assoc (cdr pair)
|
|
1214 '((read . "\\Seen")
|
|
1215 (tick . "\\Flagged")
|
|
1216 (draft . "\\Draft")
|
|
1217 (reply . "\\Answered")))
|
|
1218 (cons (cdr pair)
|
|
1219 (format "gnus-%s" (symbol-name (cdr pair))))))
|
|
1220 (cons '(read . read) gnus-article-mark-lists)))
|
|
1221
|
|
1222 (defun nnimap-mark-to-flag-1 (preds)
|
|
1223 (if (and (not (null preds)) (listp preds))
|
|
1224 (cons (nnimap-mark-to-flag (car preds))
|
|
1225 (nnimap-mark-to-flag (cdr preds)))
|
|
1226 (cdr (assoc preds nnimap-mark-to-flag-alist))))
|
|
1227
|
|
1228 (defun nnimap-mark-to-flag (preds &optional always-list make-string)
|
|
1229 "Convert a Gnus mark (a symbol such as read, tick, expire) to a IMAP flag.
|
|
1230 This is a string such as \"\\Seen\", \"\\Flagged\", \"gnus-expire\", to
|
|
1231 be used in a STORE FLAGS command."
|
|
1232 (let ((result (nnimap-mark-to-flag-1 preds)))
|
|
1233 (setq result (if (and (or make-string always-list)
|
|
1234 (not (listp result)))
|
|
1235 (list result)
|
|
1236 result))
|
|
1237 (if make-string
|
|
1238 (mapconcat (lambda (flag)
|
|
1239 (if (listp flag)
|
|
1240 (mapconcat 'identity flag " ")
|
|
1241 flag))
|
|
1242 result " ")
|
|
1243 result)))
|
|
1244
|
|
1245 (defun nnimap-mark-permanent-p (mark &optional group)
|
|
1246 "Return t iff MARK can be permanently (between IMAP sessions) saved on articles, in GROUP."
|
|
1247 (imap-message-flag-permanent-p (nnimap-mark-to-flag mark)))
|
|
1248
|
|
1249 (defun nnimap-remassoc (key alist)
|
|
1250 "Delete by side effect any elements of LIST whose car is `equal' to KEY.
|
|
1251 The modified LIST is returned. If the first member
|
|
1252 of LIST has a car that is `equal' to KEY, there is no way to remove it
|
|
1253 by side effect; therefore, write `(setq foo (remassoc key foo))' to be
|
|
1254 sure of changing the value of `foo'."
|
|
1255 (when alist
|
|
1256 (if (equal key (caar alist))
|
|
1257 (cdr alist)
|
|
1258 (setcdr alist (nnimap-remassoc key (cdr alist)))
|
|
1259 alist)))
|
|
1260
|
|
1261 (defun nnimap-update-alist-soft (key value alist)
|
|
1262 (if value
|
|
1263 (cons (cons key value) (nnimap-remassoc key alist))
|
|
1264 (nnimap-remassoc key alist)))
|
|
1265
|
|
1266 (when nnimap-debug
|
|
1267 (require 'trace)
|
|
1268 (buffer-disable-undo (get-buffer-create nnimap-debug))
|
|
1269 (mapcar (lambda (f) (trace-function-background f nnimap-debug))
|
|
1270 '(
|
|
1271 nnimap-possibly-change-server
|
|
1272 nnimap-verify-uidvalidity
|
|
1273 nnimap-find-minmax-uid
|
|
1274 nnimap-before-find-minmax-bugworkaround
|
|
1275 nnimap-possibly-change-group
|
|
1276 ;;nnimap-replace-whitespace
|
|
1277 nnimap-retrieve-headers-progress
|
|
1278 nnimap-retrieve-which-headers
|
|
1279 nnimap-group-overview-filename
|
|
1280 nnimap-retrieve-headers-from-file
|
|
1281 nnimap-retrieve-headers-from-server
|
|
1282 nnimap-retrieve-headers
|
|
1283 nnimap-open-connection
|
|
1284 nnimap-open-server
|
|
1285 nnimap-server-opened
|
|
1286 nnimap-close-server
|
|
1287 nnimap-request-close
|
|
1288 nnimap-status-message
|
|
1289 ;;nnimap-demule
|
|
1290 nnimap-request-article-part
|
|
1291 nnimap-request-article
|
|
1292 nnimap-request-head
|
|
1293 nnimap-request-body
|
|
1294 nnimap-request-group
|
|
1295 nnimap-close-group
|
|
1296 nnimap-pattern-to-list-arguments
|
|
1297 nnimap-request-list
|
|
1298 nnimap-request-post
|
|
1299 nnimap-retrieve-groups
|
|
1300 nnimap-request-update-info-internal
|
|
1301 nnimap-request-type
|
|
1302 nnimap-request-set-mark
|
|
1303 nnimap-split-to-groups
|
|
1304 nnimap-split-find-rule
|
|
1305 nnimap-split-find-inbox
|
|
1306 nnimap-split-articles
|
|
1307 nnimap-request-scan
|
|
1308 nnimap-request-newgroups
|
|
1309 nnimap-request-create-group
|
|
1310 nnimap-time-substract
|
|
1311 nnimap-date-days-ago
|
|
1312 nnimap-request-expire-articles-progress
|
|
1313 nnimap-request-expire-articles
|
|
1314 nnimap-request-move-article
|
|
1315 nnimap-request-accept-article
|
|
1316 nnimap-request-delete-group
|
|
1317 nnimap-request-rename-group
|
|
1318 gnus-group-nnimap-expunge
|
|
1319 gnus-group-nnimap-edit-acl
|
|
1320 gnus-group-nnimap-edit-acl-done
|
|
1321 nnimap-group-mode-hook
|
|
1322 nnimap-mark-to-predicate
|
|
1323 nnimap-mark-to-flag-1
|
|
1324 nnimap-mark-to-flag
|
|
1325 nnimap-mark-permanent-p
|
|
1326 nnimap-remassoc
|
|
1327 nnimap-update-alist-soft
|
|
1328 )))
|
|
1329
|
|
1330 (provide 'nnimap)
|
|
1331
|
|
1332 ;;; nnimap.el ends here
|