1 ;;; nnmaildir.el --- maildir backend for Gnus
4 ;; Author: Paul Jarc <prj@po.cwru.edu>
6 ;; This file is part of GNU Emacs.
8 ;; GNU Emacs is free software; you can redistribute it and/or modify
9 ;; it under the terms of the GNU General Public License as published by
10 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; GNU Emacs is distributed in the hope that it will be useful,
14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;; GNU General Public License for more details.
18 ;; You should have received a copy of the GNU General Public License
19 ;; along with GNU Emacs; see the file COPYING. If not, write to the
20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 ;; Boston, MA 02111-1307, USA.
25 ;; Maildir format is documented at <URL:http://cr.yp.to/proto/maildir.html>
26 ;; and in the maildir(5) man page from qmail (available at
27 ;; <URL:http://www.qmail.org/man/man5/maildir.html>). nnmaildir also stores
28 ;; extra information in the .nnmaildir/ directory within a maildir.
30 ;; Some goals of nnmaildir:
31 ;; * Everything Just Works, and correctly. E.g., NOV data is automatically
32 ;; regenerated when stale; no need for manually running
33 ;; *-generate-nov-databases.
34 ;; * Perfect reliability: [C-g] will never corrupt its data in memory, and
35 ;; SIGKILL will never corrupt its data in the filesystem.
36 ;; * Allow concurrent operation as much as possible. If files change out
37 ;; from under us, adapt to the changes or degrade gracefully.
38 ;; * We use the filesystem as a database, so that, e.g., it's easy to
39 ;; manipulate marks from outside Gnus.
40 ;; * All information about a group is stored in the maildir, for easy backup,
41 ;; copying, restoring, etc.
44 ;; * Add a hook for when moving messages from new/ to cur/, to support
45 ;; nnmail's duplicate detection.
46 ;; * Improve generated Xrefs, so crossposts are detectable.
47 ;; * Improve code readability.
51 ;; eval this before editing
53 (put 'nnmaildir--with-nntp-buffer
'lisp-indent-function
0)
54 (put 'nnmaildir--with-work-buffer
'lisp-indent-function
0)
55 (put 'nnmaildir--with-nov-buffer
'lisp-indent-function
0)
56 (put 'nnmaildir--with-move-buffer
'lisp-indent-function
0)
72 (defconst nnmaildir-version
"Gnus")
74 (defvar nnmaildir-article-file-name nil
75 "*The filename of the most recently requested article. This variable is set
76 by nnmaildir-request-article.")
78 ;; The filename of the article being moved/copied:
79 (defvar nnmaildir--file nil
)
81 ;; Variables to generate filenames of messages being delivered:
82 (defvar nnmaildir--delivery-time
"")
83 (defconst nnmaildir--delivery-pid
(concat "P" (number-to-string (emacs-pid))))
84 (defvar nnmaildir--delivery-count nil
)
86 ;; An obarry containing symbols whose names are server names and whose values
88 (defvar nnmaildir--servers
(make-vector 3 0))
89 ;; The current server:
90 (defvar nnmaildir--cur-server nil
)
92 ;; A copy of nnmail-extra-headers
93 (defvar nnmaildir--extra nil
)
95 ;; A NOV structure looks like this (must be prin1-able, so no defstruct):
96 ["subject\tfrom\tdate"
97 "references\tchars\lines"
98 "To: you\tIn-Reply-To: <your.mess@ge>"
99 (12345 67890) ;; modtime of the corresponding article file
100 (to in-reply-to
)] ;; contemporary value of nnmail-extra-headers
101 (defconst nnmaildir--novlen
5)
102 (defmacro nnmaildir--nov-new
(beg mid end mtime extra
)
103 `(vector ,beg
,mid
,end
,mtime
,extra
))
104 (defmacro nnmaildir--nov-get-beg
(nov) `(aref ,nov
0))
105 (defmacro nnmaildir--nov-get-mid
(nov) `(aref ,nov
1))
106 (defmacro nnmaildir--nov-get-end
(nov) `(aref ,nov
2))
107 (defmacro nnmaildir--nov-get-mtime
(nov) `(aref ,nov
3))
108 (defmacro nnmaildir--nov-get-extra
(nov) `(aref ,nov
4))
109 (defmacro nnmaildir--nov-set-beg
(nov value
) `(aset ,nov
0 ,value
))
110 (defmacro nnmaildir--nov-set-mid
(nov value
) `(aset ,nov
1 ,value
))
111 (defmacro nnmaildir--nov-set-end
(nov value
) `(aset ,nov
2 ,value
))
112 (defmacro nnmaildir--nov-set-mtime
(nov value
) `(aset ,nov
3 ,value
))
113 (defmacro nnmaildir--nov-set-extra
(nov value
) `(aset ,nov
4 ,value
))
115 (defstruct nnmaildir--art
116 (prefix nil
:type string
) ;; "time.pid.host"
117 (suffix nil
:type string
) ;; ":2,flags"
118 (num nil
:type natnum
) ;; article number
119 (msgid nil
:type string
) ;; "<mess.age@id>"
120 (nov nil
:type vector
)) ;; cached nov structure, or nil
122 (defstruct nnmaildir--grp
123 (name nil
:type string
) ;; "group.name"
124 (new nil
:type list
) ;; new/ modtime
125 (cur nil
:type list
) ;; cur/ modtime
126 (min 1 :type natnum
) ;; minimum article number
127 (count 0 :type natnum
) ;; count of articles
128 (nlist nil
:type list
) ;; list of articles, ordered descending by number
129 (flist nil
:type vector
) ;; obarray mapping filename prefix->article
130 (mlist nil
:type vector
) ;; obarray mapping message-id->article
131 (cache nil
:type vector
) ;; nov cache
132 (index nil
:type natnum
) ;; index of next cache entry to replace
133 (mmth nil
:type vector
)) ;; obarray mapping mark name->dir modtime
134 ; ("Mark Mod Time Hash")
136 (defstruct nnmaildir--srv
137 (address nil
:type string
) ;; server address string
138 (method nil
:type list
) ;; (nnmaildir "address" ...)
139 (prefix nil
:type string
) ;; "nnmaildir+address:"
140 (dir nil
:type string
) ;; "/expanded/path/to/server/dir/"
141 (ls nil
:type function
) ;; directory-files function
142 (groups nil
:type vector
) ;; obarray mapping group name->group
143 (curgrp nil
:type nnmaildir--grp
) ;; current group, or nil
144 (error nil
:type string
) ;; last error message, or nil
145 (mtime nil
:type list
) ;; modtime of dir
146 (gnm nil
) ;; flag: split from mail-sources?
147 (target-prefix nil
:type string
)) ;; symlink target prefix
149 (defun nnmaildir--expired-article (group article
)
150 (setf (nnmaildir--art-nov article
) nil
)
151 (let ((flist (nnmaildir--grp-flist group
))
152 (mlist (nnmaildir--grp-mlist group
))
153 (min (nnmaildir--grp-min group
))
154 (count (1- (nnmaildir--grp-count group
)))
155 (prefix (nnmaildir--art-prefix article
))
156 (msgid (nnmaildir--art-msgid article
))
158 (nlist-pre '(nil . nil
))
160 (unless (zerop count
)
161 (setq nlist-post
(nnmaildir--grp-nlist group
)
162 num
(nnmaildir--art-num article
))
163 (if (eq num
(caar nlist-post
))
164 (setq new-nlist
(cdr nlist-post
))
165 (setq new-nlist nlist-post
167 nlist-post
(cdr nlist-post
))
168 (while (/= num
(caar nlist-post
))
169 (setq nlist-pre nlist-post
170 nlist-post
(cdr nlist-post
)))
171 (setq nlist-post
(cdr nlist-post
))
173 (setq min
(caar nlist-pre
)))))
174 (let ((inhibit-quit t
))
175 (setf (nnmaildir--grp-min group
) min
)
176 (setf (nnmaildir--grp-count group
) count
)
177 (setf (nnmaildir--grp-nlist group
) new-nlist
)
178 (setcdr nlist-pre nlist-post
)
179 (unintern prefix flist
)
180 (unintern msgid mlist
))))
182 (defun nnmaildir--nlist-art (group num
)
183 (let ((entry (assq num
(nnmaildir--grp-nlist group
))))
186 (defmacro nnmaildir--flist-art
(list file
)
187 `(symbol-value (intern-soft ,file
,list
)))
188 (defmacro nnmaildir--mlist-art
(list msgid
)
189 `(symbol-value (intern-soft ,msgid
,list
)))
191 (defun nnmaildir--pgname (server gname
)
192 (let ((prefix (nnmaildir--srv-prefix server
)))
193 (if prefix
(concat prefix gname
)
194 (setq gname
(gnus-group-prefixed-name gname
195 (nnmaildir--srv-method server
)))
196 (setf (nnmaildir--srv-prefix server
) (gnus-group-real-prefix gname
))
199 (defun nnmaildir--param (pgname param
)
200 (setq param
(gnus-group-find-parameter pgname param
'allow-list
))
201 (if (vectorp param
) (setq param
(aref param
0)))
204 (defmacro nnmaildir--with-nntp-buffer
(&rest body
)
206 (set-buffer nntp-server-buffer
)
208 (defmacro nnmaildir--with-work-buffer
(&rest body
)
210 (set-buffer (get-buffer-create " *nnmaildir work*"))
212 (defmacro nnmaildir--with-nov-buffer
(&rest body
)
214 (set-buffer (get-buffer-create " *nnmaildir nov*"))
216 (defmacro nnmaildir--with-move-buffer
(&rest body
)
218 (set-buffer (get-buffer-create " *nnmaildir move*"))
221 (defmacro nnmaildir--subdir
(dir subdir
)
222 `(file-name-as-directory (concat ,dir
,subdir
)))
223 (defmacro nnmaildir--srvgrp-dir
(srv-dir gname
)
224 `(nnmaildir--subdir ,srv-dir
,gname
))
225 (defmacro nnmaildir--tmp
(dir) `(nnmaildir--subdir ,dir
"tmp"))
226 (defmacro nnmaildir--new
(dir) `(nnmaildir--subdir ,dir
"new"))
227 (defmacro nnmaildir--cur
(dir) `(nnmaildir--subdir ,dir
"cur"))
228 (defmacro nnmaildir--nndir
(dir) `(nnmaildir--subdir ,dir
".nnmaildir"))
229 (defmacro nnmaildir--nov-dir
(dir) `(nnmaildir--subdir ,dir
"nov"))
230 (defmacro nnmaildir--marks-dir
(dir) `(nnmaildir--subdir ,dir
"marks"))
231 (defmacro nnmaildir--num-dir
(dir) `(nnmaildir--subdir ,dir
"num"))
232 (defmacro nnmaildir--num-file
(dir) `(concat ,dir
":"))
234 (defmacro nnmaildir--unlink
(file-arg)
235 `(let ((file ,file-arg
))
236 (if (file-attributes file
) (delete-file file
))))
237 (defun nnmaildir--mkdir (dir)
238 (or (file-exists-p (file-name-as-directory dir
))
239 (make-directory-internal (directory-file-name dir
))))
240 (defun nnmaildir--delete-dir-files (dir ls
)
241 (when (file-attributes dir
)
242 (mapcar 'delete-file
(funcall ls dir
'full
"\\`[^.]" 'nosort
))
243 (delete-directory dir
)))
245 (defun nnmaildir--group-maxnum (server group
)
246 (if (zerop (nnmaildir--grp-count group
)) 0
247 (let ((x (nnmaildir--srvgrp-dir (nnmaildir--srv-dir server
)
248 (nnmaildir--grp-name group
))))
249 (setq x
(nnmaildir--nndir x
)
250 x
(nnmaildir--num-dir x
)
251 x
(nnmaildir--num-file x
)
252 x
(file-attributes x
))
253 (if x
(1- (nth 1 x
)) 0))))
255 ;; Make the given server, if non-nil, be the current server. Then make the
256 ;; given group, if non-nil, be the current group of the current server. Then
257 ;; return the group object for the current group.
258 (defun nnmaildir--prepare (server group
)
262 (unless (setq server nnmaildir--cur-server
)
264 (unless (setq server
(intern-soft server nnmaildir--servers
))
266 (setq server
(symbol-value server
)
267 nnmaildir--cur-server server
))
268 (unless (setq groups
(nnmaildir--srv-groups server
))
270 (unless (nnmaildir--srv-method server
)
271 (setq x
(concat "nnmaildir:" (nnmaildir--srv-address server
))
272 x
(gnus-server-to-method x
))
273 (unless x
(throw 'return nil
))
274 (setf (nnmaildir--srv-method server
) x
))
276 (unless (setq group
(nnmaildir--srv-curgrp server
))
278 (unless (setq group
(intern-soft group groups
))
280 (setq group
(symbol-value group
)))
283 (defun nnmaildir--tab-to-space (string)
285 (while (string-match "\t" string pos
)
286 (aset string
(match-beginning 0) ?
)
287 (setq pos
(match-end 0))))
290 (defun nnmaildir--update-nov (server group article
)
291 (let ((nnheader-file-coding-system 'binary
)
292 (srv-dir (nnmaildir--srv-dir server
))
293 (storage-version 1) ;; [version article-number msgid [...nov...]]
294 dir gname pgname msgdir prefix suffix file attr mtime novdir novfile
295 nov msgid nov-beg nov-mid nov-end field val old-extra num numdir
298 (setq gname
(nnmaildir--grp-name group
)
299 pgname
(nnmaildir--pgname server gname
)
300 dir
(nnmaildir--srvgrp-dir srv-dir gname
)
301 msgdir
(if (nnmaildir--param pgname
'read-only
)
302 (nnmaildir--new dir
) (nnmaildir--cur dir
))
303 prefix
(nnmaildir--art-prefix article
)
304 suffix
(nnmaildir--art-suffix article
)
305 file
(concat msgdir prefix suffix
)
306 attr
(file-attributes file
))
308 (nnmaildir--expired-article group article
)
310 (setq mtime
(nth 5 attr
)
312 nov
(nnmaildir--art-nov article
)
313 dir
(nnmaildir--nndir dir
)
314 novdir
(nnmaildir--nov-dir dir
)
315 novfile
(concat novdir prefix
))
316 (unless (equal nnmaildir--extra nnmail-extra-headers
)
317 (setq nnmaildir--extra
(copy-sequence nnmail-extra-headers
)))
318 (nnmaildir--with-nov-buffer
319 ;; First we'll check for already-parsed NOV data.
320 (cond ((not (file-exists-p novfile
))
321 ;; The NOV file doesn't exist; we have to parse the message.
324 ;; The file exists, but the data isn't in memory; read the file.
326 (nnheader-insert-file-contents novfile
)
327 (setq nov
(read (current-buffer)))
328 (if (not (and (vectorp nov
)
330 (equal storage-version
(aref nov
0))))
331 ;; This NOV data seems to be in the wrong format.
333 (unless (nnmaildir--art-num article
)
334 (setf (nnmaildir--art-num article
) (aref nov
1)))
335 (unless (nnmaildir--art-msgid article
)
336 (setf (nnmaildir--art-msgid article
) (aref nov
2)))
337 (setq nov
(aref nov
3)))))
338 ;; Now check whether the already-parsed data (if we have any) is
339 ;; usable: if the message has been edited or if nnmail-extra-headers
340 ;; has been augmented since this data was parsed from the message,
341 ;; then we have to reparse. Otherwise it's up-to-date.
342 (when (and nov
(equal mtime
(nnmaildir--nov-get-mtime nov
)))
343 ;; The timestamp matches. Now check nnmail-extra-headers.
344 (setq old-extra
(nnmaildir--nov-get-extra nov
))
345 (when (equal nnmaildir--extra old-extra
) ;; common case
346 ;; Save memory; use a single copy of the list value.
347 (nnmaildir--nov-set-extra nov nnmaildir--extra
)
349 ;; They're not equal, but maybe the new is a subset of the old.
350 (if (null nnmaildir--extra
)
351 ;; The empty set is a subset of every set.
353 (if (not (memq nil
(mapcar (lambda (e) (memq e old-extra
))
355 (throw 'return nov
)))
356 ;; Parse the NOV data out of the message.
358 (nnheader-insert-file-contents file
)
360 (goto-char (point-min))
362 (if (search-forward "\n\n" nil
'noerror
)
364 (setq nov-mid
(count-lines (point) (point-max)))
365 (narrow-to-region (point-min) (1- (point))))
367 (goto-char (point-min))
369 (setq nov
(nnheader-parse-naked-head)
370 field
(or (mail-header-lines nov
) 0)))
371 (unless (or (zerop field
) (nnmaildir--param pgname
'distrust-Lines
:))
372 (setq nov-mid field
))
373 (setq nov-mid
(number-to-string nov-mid
)
374 nov-mid
(concat (number-to-string attr
) "\t" nov-mid
))
376 (setq field
(or (mail-header-references nov
) ""))
377 (nnmaildir--tab-to-space field
)
378 (setq nov-mid
(concat field
"\t" nov-mid
)
380 (lambda (f) (nnmaildir--tab-to-space (or f
"")))
381 (list (mail-header-subject nov
)
382 (mail-header-from nov
)
383 (mail-header-date nov
)) "\t")
386 (setq field
(symbol-name (car extra
))
388 (nnmaildir--tab-to-space field
)
389 (nnmaildir--tab-to-space val
)
390 (concat field
": " val
))
391 (mail-header-extra nov
) "\t")))
392 (setq msgid
(mail-header-id nov
))
393 (if (or (null msgid
) (nnheader-fake-message-id-p msgid
))
394 (setq msgid
(concat "<" prefix
"@nnmaildir>")))
395 (nnmaildir--tab-to-space msgid
)
396 ;; The data is parsed; create an nnmaildir NOV structure.
397 (setq nov
(nnmaildir--nov-new nov-beg nov-mid nov-end mtime
399 num
(nnmaildir--art-num article
))
401 ;; Allocate a new article number.
403 (setq numdir
(nnmaildir--num-dir dir
)
404 file
(nnmaildir--num-file numdir
)
406 (nnmaildir--mkdir numdir
)
407 (write-region "" nil file nil
'no-message
)
409 ;; Get the number of links to file.
410 (setq attr
(nth 1 (file-attributes file
)))
412 ;; We've already tried this number, in the previous loop
413 ;; iteration, and failed.
414 (signal 'error
`("Corrupt internal nnmaildir data" ,numdir
)))
415 ;; If attr is 123, try to link file to "123". This atomically
416 ;; increases the link count and creates the "123" link, failing
417 ;; if that link was already created by another Gnus, just after
421 (add-name-to-file file
(concat numdir
(format "%x" attr
)))
422 (setq file nil
)) ;; Stop looping.
423 (file-already-exists nil
))
425 (setf (nnmaildir--art-num article
) num
))
426 ;; Store this new NOV data in a file
428 (prin1 (vector storage-version num msgid nov
) (current-buffer))
429 (setq file
(concat novfile
":"))
430 (nnmaildir--unlink file
)
431 (write-region (point-min) (point-max) file nil
'no-message nil
'excl
))
432 (rename-file file novfile
'replace
)
433 (setf (nnmaildir--art-msgid article
) msgid
)
436 (defun nnmaildir--cache-nov (group article nov
)
437 (let ((cache (nnmaildir--grp-cache group
))
438 (index (nnmaildir--grp-index group
))
440 (unless (nnmaildir--art-nov article
)
441 (setq goner
(aref cache index
))
442 (if goner
(setf (nnmaildir--art-nov goner
) nil
))
443 (aset cache index article
)
444 (setf (nnmaildir--grp-index group
) (%
(1+ index
) (length cache
))))
445 (setf (nnmaildir--art-nov article
) nov
)))
447 (defun nnmaildir--grp-add-art (server group article
)
448 (let ((nov (nnmaildir--update-nov server group article
))
449 count num min nlist nlist-cdr insert-nlist
)
451 (setq count
(1+ (nnmaildir--grp-count group
))
452 num
(nnmaildir--art-num article
)
453 min
(if (= count
1) num
454 (min num
(nnmaildir--grp-min group
)))
455 nlist
(nnmaildir--grp-nlist group
))
456 (if (or (null nlist
) (> num
(caar nlist
)))
457 (setq nlist
(cons (cons num article
) nlist
))
459 nlist-cdr
(cdr nlist
))
460 (while (and nlist-cdr
(< num
(caar nlist-cdr
)))
461 (setq nlist nlist-cdr
462 nlist-cdr
(cdr nlist
))))
463 (let ((inhibit-quit t
))
464 (setf (nnmaildir--grp-count group
) count
)
465 (setf (nnmaildir--grp-min group
) min
)
467 (setcdr nlist
(cons (cons num article
) nlist-cdr
))
468 (setf (nnmaildir--grp-nlist group
) nlist
))
469 (set (intern (nnmaildir--art-prefix article
)
470 (nnmaildir--grp-flist group
))
472 (set (intern (nnmaildir--art-msgid article
)
473 (nnmaildir--grp-mlist group
))
475 (set (intern (nnmaildir--grp-name group
)
476 (nnmaildir--srv-groups server
))
478 (nnmaildir--cache-nov group article nov
)
481 (defun nnmaildir--group-ls (server pgname
)
482 (or (nnmaildir--param pgname
'directory-files
)
483 (nnmaildir--srv-ls server
)))
485 (defun nnmaildir-article-number-to-file-name
486 (number group-name server-address-string
)
487 (let ((group (nnmaildir--prepare server-address-string group-name
))
491 ;; The given group or server does not exist.
493 (setq article
(nnmaildir--nlist-art group number
))
495 ;; The given article number does not exist in this group.
497 (setq pgname
(nnmaildir--pgname nnmaildir--cur-server group-name
)
498 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
499 dir
(nnmaildir--srvgrp-dir dir group-name
)
500 dir
(if (nnmaildir--param pgname
'read-only
)
501 (nnmaildir--new dir
) (nnmaildir--cur dir
)))
502 (concat dir
(nnmaildir--art-prefix article
)
503 (nnmaildir--art-suffix article
)))))
505 (defun nnmaildir-article-number-to-base-name
506 (number group-name server-address-string
)
507 (let ((x (nnmaildir--prepare server-address-string group-name
)))
509 (setq x
(nnmaildir--nlist-art x number
))
510 (and x
(cons (nnmaildir--art-prefix x
)
511 (nnmaildir--art-suffix x
))))))
513 (defun nnmaildir-base-name-to-article-number
514 (base-name group-name server-address-string
)
515 (let ((x (nnmaildir--prepare server-address-string group-name
)))
517 (setq x
(nnmaildir--grp-flist x
)
518 x
(nnmaildir--flist-art x base-name
))
519 (and x
(nnmaildir--art-num x
)))))
521 (defun nnmaildir--nlist-iterate (nlist ranges func
)
522 (let (entry high low nlist2
)
524 (setq ranges
`((1 .
,(caar nlist
)))))
526 (setq entry
(car ranges
) ranges
(cdr ranges
))
527 (while (and ranges
(eq entry
(car ranges
)))
528 (setq ranges
(cdr ranges
))) ;; skip duplicates
532 (setq low
(car entry
)
534 (setq nlist2 nlist
) ;; Don't assume any sorting of ranges
537 (if (<= (caar nlist2
) high
) (throw 'iterate-loop nil
))
538 (setq nlist2
(cdr nlist2
))))
541 (setq entry
(car nlist2
) nlist2
(cdr nlist2
))
542 (if (< (car entry
) low
) (throw 'iterate-loop nil
))
543 (funcall func
(cdr entry
)))))))
545 (defun nnmaildir--up2-1 (n)
546 (if (zerop n
) 1 (1- (lsh 1 (1+ (logb n
))))))
548 (defun nnmaildir--system-name ()
549 (gnus-replace-in-string
550 (gnus-replace-in-string
551 (gnus-replace-in-string
553 "\\\\" "\\134" 'literal
)
554 "/" "\\057" 'literal
)
555 ":" "\\072" 'literal
))
557 (defun nnmaildir-request-type (group &optional article
)
560 (defun nnmaildir-status-message (&optional server
)
561 (nnmaildir--prepare server nil
)
562 (nnmaildir--srv-error nnmaildir--cur-server
))
564 (defun nnmaildir-server-opened (&optional server
)
565 (and nnmaildir--cur-server
567 (string-equal server
(nnmaildir--srv-address nnmaildir--cur-server
))
569 (nnmaildir--srv-groups nnmaildir--cur-server
)
572 (defun nnmaildir-open-server (server &optional defs
)
576 (setq server
(intern-soft x nnmaildir--servers
))
578 (and (setq server
(symbol-value server
))
579 (nnmaildir--srv-groups server
)
580 (setq nnmaildir--cur-server server
)
582 (setq server
(make-nnmaildir--srv :address x
))
583 (let ((inhibit-quit t
))
584 (set (intern x nnmaildir--servers
) server
)))
585 (setq dir
(assq 'directory defs
))
587 (setf (nnmaildir--srv-error server
)
588 "You must set \"directory\" in the select method")
592 dir
(expand-file-name dir
)
593 dir
(file-name-as-directory dir
))
594 (unless (file-exists-p dir
)
595 (setf (nnmaildir--srv-error server
) (concat "No such directory: " dir
))
597 (setf (nnmaildir--srv-dir server
) dir
)
598 (setq x
(assq 'directory-files defs
))
600 (setq x
(if nnheader-directory-files-is-safe
'directory-files
601 'nnheader-directory-files-safe
))
603 (unless (functionp x
)
604 (setf (nnmaildir--srv-error server
)
605 (concat "Not a function: " (prin1-to-string x
)))
606 (throw 'return nil
)))
607 (setf (nnmaildir--srv-ls server
) x
)
608 (setq size
(length (funcall x dir nil
"\\`[^.]" 'nosort
))
609 size
(nnmaildir--up2-1 size
))
610 (and (setq x
(assq 'get-new-mail defs
))
613 (setf (nnmaildir--srv-gnm server
) t
)
615 (setq x
(assq 'target-prefix defs
))
620 (setf (nnmaildir--srv-target-prefix server
) x
))
621 (setq x
(assq 'create-directory defs
))
626 x
(file-name-as-directory x
))
627 (setf (nnmaildir--srv-target-prefix server
) x
))
628 (setf (nnmaildir--srv-target-prefix server
) "")))
629 (setf (nnmaildir--srv-groups server
) (make-vector size
0))
630 (setq nnmaildir--cur-server server
)
633 (defun nnmaildir--parse-filename (file)
634 (let ((prefix (car file
))
636 (if (string-match "\\`\\([0-9]+\\)\\(\\..*\\)\\'" prefix
)
638 (setq timestamp
(concat "0000" (match-string 1 prefix
))
639 len
(- (length timestamp
) 4))
640 (vector (string-to-number (substring timestamp
0 len
))
641 (string-to-number (substring timestamp len
))
642 (match-string 2 prefix
)
646 (defun nnmaildir--sort-files (a b
)
649 (throw 'return
(and (consp b
) (string-lessp (car a
) (car b
)))))
650 (if (consp b
) (throw 'return t
))
651 (if (< (aref a
0) (aref b
0)) (throw 'return t
))
652 (if (> (aref a
0) (aref b
0)) (throw 'return nil
))
653 (if (< (aref a
1) (aref b
1)) (throw 'return t
))
654 (if (> (aref a
1) (aref b
1)) (throw 'return nil
))
655 (string-lessp (aref a
2) (aref b
2))))
657 (defun nnmaildir--scan (gname scan-msgs groups method srv-dir srv-ls
)
659 (let ((36h-ago (- (car (current-time)) 2))
660 absdir nndir tdir ndir cdir nattr cattr isnew pgname read-only ls
661 files num dir flist group x
)
662 (setq absdir
(nnmaildir--srvgrp-dir srv-dir gname
)
663 nndir
(nnmaildir--nndir absdir
))
664 (unless (file-exists-p absdir
)
665 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
666 (concat "No such directory: " absdir
))
668 (setq tdir
(nnmaildir--tmp absdir
)
669 ndir
(nnmaildir--new absdir
)
670 cdir
(nnmaildir--cur absdir
)
671 nattr
(file-attributes ndir
)
672 cattr
(file-attributes cdir
))
673 (unless (and (file-exists-p tdir
) nattr cattr
)
674 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
675 (concat "Not a maildir: " absdir
))
677 (setq group
(nnmaildir--prepare nil gname
)
678 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
))
682 group
(make-nnmaildir--grp :name gname
:index
0))
683 (nnmaildir--mkdir nndir
)
684 (nnmaildir--mkdir (nnmaildir--nov-dir nndir
))
685 (nnmaildir--mkdir (nnmaildir--marks-dir nndir
))
686 (write-region "" nil
(concat nndir
"markfile") nil
'no-message
))
687 (setq read-only
(nnmaildir--param pgname
'read-only
)
688 ls
(or (nnmaildir--param pgname
'directory-files
) srv-ls
))
690 (setq x
(nth 11 (file-attributes tdir
)))
691 (unless (and (= x
(nth 11 nattr
)) (= x
(nth 11 cattr
)))
692 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
693 (concat "Maildir spans filesystems: " absdir
))
697 (setq x
(file-attributes file
))
698 (if (or (> (cadr x
) 1) (< (car (nth 4 x
)) 36h-ago
))
700 (funcall ls tdir
'full
"\\`[^.]" 'nosort
)))
704 (setq nattr
(nth 5 nattr
))
705 (if (equal nattr
(nnmaildir--grp-new group
))
707 (if read-only
(setq dir
(and (or isnew nattr
) ndir
))
708 (when (or isnew nattr
)
711 (let ((path (concat ndir file
)))
712 (and (time-less-p (nth 5 (file-attributes path
)) (current-time))
713 (rename-file path
(concat cdir file
":2,")))))
714 (funcall ls ndir nil
"\\`[^.]" 'nosort
))
715 (setf (nnmaildir--grp-new group
) nattr
))
716 (setq cattr
(nth 5 (file-attributes cdir
)))
717 (if (equal cattr
(nnmaildir--grp-cur group
))
719 (setq dir
(and (or isnew cattr
) cdir
)))
720 (unless dir
(throw 'return t
))
721 (setq files
(funcall ls dir nil
"\\`[^.]" 'nosort
)
722 files
(save-match-data
725 (string-match "\\`\\([^:]*\\)\\(\\(:.*\\)?\\)\\'" f
)
726 (cons (match-string 1 f
) (match-string 2 f
)))
729 (setq num
(nnmaildir--up2-1 (length files
)))
730 (setf (nnmaildir--grp-flist group
) (make-vector num
0))
731 (setf (nnmaildir--grp-mlist group
) (make-vector num
0))
732 (setf (nnmaildir--grp-mmth group
) (make-vector 1 0))
733 (setq num
(nnmaildir--param pgname
'nov-cache-size
))
734 (if (numberp num
) (if (< num
1) (setq num
1))
736 cdir
(nnmaildir--marks-dir nndir
)
737 ndir
(nnmaildir--subdir cdir
"tick")
738 cdir
(nnmaildir--subdir cdir
"read"))
741 (setq file
(car file
))
742 (if (or (not (file-exists-p (concat cdir file
)))
743 (file-exists-p (concat ndir file
)))
744 (setq num
(1+ num
))))
746 (setf (nnmaildir--grp-cache group
) (make-vector num nil
))
747 (let ((inhibit-quit t
))
748 (set (intern gname groups
) group
))
749 (or scan-msgs
(throw 'return t
)))
750 (setq flist
(nnmaildir--grp-flist group
)
753 (and (null (nnmaildir--flist-art flist
(car file
)))
756 files
(delq nil files
)
757 files
(mapcar 'nnmaildir--parse-filename files
)
758 files
(sort files
'nnmaildir--sort-files
))
761 (setq file
(if (consp file
) file
(aref file
3))
762 x
(make-nnmaildir--art :prefix
(car file
) :suffix
(cdr file
)))
763 (nnmaildir--grp-add-art nnmaildir--cur-server group x
))
765 (if read-only
(setf (nnmaildir--grp-new group
) nattr
)
766 (setf (nnmaildir--grp-cur group
) cattr
)))
769 (defun nnmaildir-request-scan (&optional scan-group server
)
770 (let ((coding-system-for-write nnheader-file-coding-system
)
771 (buffer-file-coding-system nil
)
772 (file-coding-system-alist nil
)
773 (nnmaildir-get-new-mail t
)
774 (nnmaildir-group-alist nil
)
775 (nnmaildir-active-file nil
)
776 x srv-ls srv-dir method groups target-prefix group dirs grp-dir seen
778 (nnmaildir--prepare server nil
)
779 (setq srv-ls
(nnmaildir--srv-ls nnmaildir--cur-server
)
780 srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
781 method
(nnmaildir--srv-method nnmaildir--cur-server
)
782 groups
(nnmaildir--srv-groups nnmaildir--cur-server
)
783 target-prefix
(nnmaildir--srv-target-prefix nnmaildir--cur-server
))
784 (nnmaildir--with-work-buffer
786 (if (stringp scan-group
)
787 (if (nnmaildir--scan scan-group t groups method srv-dir srv-ls
)
788 (if (nnmaildir--srv-gnm nnmaildir--cur-server
)
789 (nnmail-get-new-mail 'nnmaildir nil nil scan-group
))
790 (unintern scan-group groups
))
791 (setq x
(nth 5 (file-attributes srv-dir
))
792 scan-group
(null scan-group
))
793 (if (equal x
(nnmaildir--srv-mtime nnmaildir--cur-server
))
795 (mapatoms (lambda (sym)
796 (nnmaildir--scan (symbol-name sym
) t groups
797 method srv-dir srv-ls
))
799 (setq dirs
(funcall srv-ls srv-dir nil
"\\`[^.]" 'nosort
)
800 dirs
(if (zerop (length target-prefix
))
804 (and (>= (length dir
) (length target-prefix
))
805 (string= (substring dir
0
806 (length target-prefix
))
809 seen
(nnmaildir--up2-1 (length dirs
))
810 seen
(make-vector seen
0))
813 (if (nnmaildir--scan grp-dir scan-group groups method srv-dir
815 (intern grp-dir seen
)))
818 (mapatoms (lambda (group)
819 (setq group
(symbol-name group
))
820 (unless (intern-soft group seen
)
821 (setq x
(cons group x
))))
823 (mapcar (lambda (grp) (unintern grp groups
)) x
)
824 (setf (nnmaildir--srv-mtime nnmaildir--cur-server
)
825 (nth 5 (file-attributes srv-dir
))))
827 (nnmaildir--srv-gnm nnmaildir--cur-server
)
828 (nnmail-get-new-mail 'nnmaildir nil nil
))))))
831 (defun nnmaildir-request-list (&optional server
)
832 (nnmaildir-request-scan 'find-new-groups server
)
833 (let (pgname ro deactivate-mark
)
834 (nnmaildir--prepare server nil
)
835 (nnmaildir--with-nntp-buffer
837 (mapatoms (lambda (group)
838 (setq pgname
(symbol-name group
)
839 pgname
(nnmaildir--pgname nnmaildir--cur-server pgname
)
840 group
(symbol-value group
)
841 ro
(nnmaildir--param pgname
'read-only
))
842 (insert (nnmaildir--grp-name group
) " ")
843 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group
)
846 (princ (nnmaildir--grp-min group
) nntp-server-buffer
)
847 (insert " " (if ro
"n" "y") "\n"))
848 (nnmaildir--srv-groups nnmaildir--cur-server
))))
851 (defun nnmaildir-request-newgroups (date &optional server
)
852 (nnmaildir-request-list server
))
854 (defun nnmaildir-retrieve-groups (groups &optional server
)
855 (let (group deactivate-mark
)
856 (nnmaildir--prepare server nil
)
857 (nnmaildir--with-nntp-buffer
861 (setq group
(nnmaildir--prepare nil gname
))
862 (if (null group
) (insert "411 no such news group\n")
864 (princ (nnmaildir--grp-count group
) nntp-server-buffer
)
866 (princ (nnmaildir--grp-min group
) nntp-server-buffer
)
868 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group
)
870 (insert " " gname
"\n")))
874 (defun nnmaildir-request-update-info (gname info
&optional server
)
875 (let ((group (nnmaildir--prepare server gname
))
876 pgname flist always-marks never-marks old-marks dotfile num dir
877 markdirs marks mark ranges markdir article read end new-marks ls
878 old-mmth new-mmth mtime mark-sym existing missing deactivate-mark
)
881 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
882 (concat "No such group: " gname
))
884 (setq gname
(nnmaildir--grp-name group
)
885 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
886 flist
(nnmaildir--grp-flist group
))
887 (when (zerop (nnmaildir--grp-count group
))
888 (gnus-info-set-read info nil
)
889 (gnus-info-set-marks info nil
'extend
)
890 (throw 'return info
))
891 (setq old-marks
(cons 'read
(gnus-info-read info
))
892 old-marks
(cons old-marks
(gnus-info-marks info
))
893 always-marks
(nnmaildir--param pgname
'always-marks
)
894 never-marks
(nnmaildir--param pgname
'never-marks
)
895 existing
(nnmaildir--grp-nlist group
)
896 existing
(mapcar 'car existing
)
897 existing
(nreverse existing
)
898 existing
(gnus-compress-sequence existing
'always-list
)
899 missing
(list (cons 1 (nnmaildir--group-maxnum
900 nnmaildir--cur-server group
)))
901 missing
(gnus-range-difference missing existing
)
902 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
903 dir
(nnmaildir--srvgrp-dir dir gname
)
904 dir
(nnmaildir--nndir dir
)
905 dir
(nnmaildir--marks-dir dir
)
906 ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
)
907 markdirs
(funcall ls dir nil
"\\`[^.]" 'nosort
)
908 new-mmth
(nnmaildir--up2-1 (length markdirs
))
909 new-mmth
(make-vector new-mmth
0)
910 old-mmth
(nnmaildir--grp-mmth group
))
913 (setq markdir
(nnmaildir--subdir dir mark
)
914 mark-sym
(intern mark
)
917 (if (memq mark-sym never-marks
) (throw 'got-ranges nil
))
918 (when (memq mark-sym always-marks
)
919 (setq ranges existing
)
920 (throw 'got-ranges nil
))
921 (setq mtime
(nth 5 (file-attributes markdir
)))
922 (set (intern mark new-mmth
) mtime
)
923 (when (equal mtime
(symbol-value (intern-soft mark old-mmth
)))
924 (setq ranges
(assq mark-sym old-marks
))
925 (if ranges
(setq ranges
(cdr ranges
)))
926 (throw 'got-ranges nil
))
929 (setq article
(nnmaildir--flist-art flist prefix
))
932 (gnus-add-to-range ranges
933 `(,(nnmaildir--art-num article
))))))
934 (funcall ls markdir nil
"\\`[^.]" 'nosort
)))
935 (if (eq mark-sym
'read
) (setq read ranges
)
936 (if ranges
(setq marks
(cons (cons mark-sym ranges
) marks
)))))
938 (gnus-info-set-read info
(gnus-range-add read missing
))
939 (gnus-info-set-marks info marks
'extend
)
940 (setf (nnmaildir--grp-mmth group
) new-mmth
)
943 (defun nnmaildir-request-group (gname &optional server fast
)
944 (let ((group (nnmaildir--prepare server gname
))
948 ;; (insert "411 no such news group\n")
949 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
950 (concat "No such group: " gname
))
952 (setf (nnmaildir--srv-curgrp nnmaildir--cur-server
) group
)
953 (if fast
(throw 'return t
))
954 (nnmaildir--with-nntp-buffer
957 (princ (nnmaildir--grp-count group
) nntp-server-buffer
)
959 (princ (nnmaildir--grp-min group
) nntp-server-buffer
)
961 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group
)
963 (insert " " gname
"\n")
966 (defun nnmaildir-request-create-group (gname &optional server args
)
967 (nnmaildir--prepare server nil
)
969 (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server
))
971 (when (zerop (length gname
))
972 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
973 "Invalid (empty) group name")
975 (when (eq (aref "." 0) (aref gname
0))
976 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
977 "Group names may not start with \".\"")
979 (when (save-match-data (string-match "[\0/\t]" gname
))
980 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
981 (concat "Illegal characters (null, tab, or /) in group name: "
984 (setq groups
(nnmaildir--srv-groups nnmaildir--cur-server
))
985 (when (intern-soft gname groups
)
986 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
987 (concat "Group already exists: " gname
))
989 (setq srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
))
990 (if (file-name-absolute-p target-prefix
)
991 (setq dir
(expand-file-name target-prefix
))
993 dir
(file-truename dir
)
994 dir
(concat dir target-prefix
)))
995 (setq dir
(nnmaildir--subdir dir gname
))
996 (nnmaildir--mkdir dir
)
997 (nnmaildir--mkdir (nnmaildir--tmp dir
))
998 (nnmaildir--mkdir (nnmaildir--new dir
))
999 (nnmaildir--mkdir (nnmaildir--cur dir
))
1000 (unless (string= target-prefix
"")
1001 (make-symbolic-link (concat target-prefix gname
)
1002 (concat srv-dir gname
)))
1003 (nnmaildir-request-scan 'find-new-groups
))))
1005 (defun nnmaildir-request-rename-group (gname new-name
&optional server
)
1006 (let ((group (nnmaildir--prepare server gname
))
1007 (coding-system-for-write nnheader-file-coding-system
)
1008 (buffer-file-coding-system nil
)
1009 (file-coding-system-alist nil
)
1013 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1014 (concat "No such group: " gname
))
1015 (throw 'return nil
))
1016 (when (zerop (length new-name
))
1017 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1018 "Invalid (empty) group name")
1019 (throw 'return nil
))
1020 (when (eq (aref "." 0) (aref new-name
0))
1021 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1022 "Group names may not start with \".\"")
1023 (throw 'return nil
))
1024 (when (save-match-data (string-match "[\0/\t]" new-name
))
1025 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1026 (concat "Illegal characters (null, tab, or /) in group name: "
1028 (throw 'return nil
))
1029 (if (string-equal gname new-name
) (throw 'return t
))
1030 (when (intern-soft new-name
1031 (nnmaildir--srv-groups nnmaildir--cur-server
))
1032 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1033 (concat "Group already exists: " new-name
))
1034 (throw 'return nil
))
1035 (setq srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
))
1037 (rename-file (concat srv-dir gname
)
1038 (concat srv-dir new-name
))
1040 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1041 (concat "Error renaming link: " (prin1-to-string err
)))
1042 (throw 'return nil
)))
1043 (setq x
(nnmaildir--srv-groups nnmaildir--cur-server
)
1044 groups
(make-vector (length x
) 0))
1045 (mapatoms (lambda (sym)
1046 (unless (eq (symbol-value sym
) group
)
1047 (set (intern (symbol-name sym
) groups
)
1048 (symbol-value sym
))))
1050 (setq group
(copy-sequence group
))
1051 (setf (nnmaildir--grp-name group
) new-name
)
1052 (set (intern new-name groups
) group
)
1053 (setf (nnmaildir--srv-groups nnmaildir--cur-server
) groups
)
1056 (defun nnmaildir-request-delete-group (gname force
&optional server
)
1057 (let ((group (nnmaildir--prepare server gname
))
1058 pgname grp-dir target dir ls deactivate-mark
)
1061 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1062 (concat "No such group: " gname
))
1063 (throw 'return nil
))
1064 (setq gname
(nnmaildir--grp-name group
)
1065 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1066 grp-dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1067 target
(car (file-attributes (concat grp-dir gname
)))
1068 grp-dir
(nnmaildir--srvgrp-dir grp-dir gname
))
1069 (unless (or force
(stringp target
))
1070 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1071 (concat "Not a symlink: " gname
))
1072 (throw 'return nil
))
1073 (if (eq group
(nnmaildir--srv-curgrp nnmaildir--cur-server
))
1074 (setf (nnmaildir--srv-curgrp nnmaildir--cur-server
) nil
))
1075 (unintern gname
(nnmaildir--srv-groups nnmaildir--cur-server
))
1078 (setq grp-dir
(directory-file-name grp-dir
))
1079 (nnmaildir--unlink grp-dir
))
1080 (setq ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
))
1081 (if (nnmaildir--param pgname
'read-only
)
1082 (progn (delete-directory (nnmaildir--tmp grp-dir
))
1083 (nnmaildir--unlink (nnmaildir--new grp-dir
))
1084 (delete-directory (nnmaildir--cur grp-dir
)))
1085 (nnmaildir--delete-dir-files (nnmaildir--tmp grp-dir
) ls
)
1086 (nnmaildir--delete-dir-files (nnmaildir--new grp-dir
) ls
)
1087 (nnmaildir--delete-dir-files (nnmaildir--cur grp-dir
) ls
))
1088 (setq dir
(nnmaildir--nndir grp-dir
))
1089 (mapcar (lambda (subdir) (nnmaildir--delete-dir-files subdir ls
))
1090 `(,(nnmaildir--nov-dir dir
) ,(nnmaildir--num-dir dir
)
1091 ,@(funcall ls
(nnmaildir--marks-dir dir
) 'full
"\\`[^.]"
1093 (setq dir
(nnmaildir--nndir grp-dir
))
1094 (nnmaildir--unlink (concat dir
"markfile"))
1095 (nnmaildir--unlink (concat dir
"markfile{new}"))
1096 (delete-directory (nnmaildir--marks-dir dir
))
1097 (delete-directory dir
)
1098 (if (not (stringp target
))
1099 (delete-directory grp-dir
)
1100 (setq grp-dir
(directory-file-name grp-dir
)
1102 (unless (eq (aref "/" 0) (aref dir
0))
1103 (setq dir
(concat (file-truename
1104 (nnmaildir--srv-dir nnmaildir--cur-server
))
1106 (delete-directory dir
)
1107 (nnmaildir--unlink grp-dir
)))
1110 (defun nnmaildir-retrieve-headers (articles &optional gname server fetch-old
)
1111 (let ((group (nnmaildir--prepare server gname
))
1112 srv-dir dir nlist mlist article num start stop nov nlist2 insert-nov
1116 (setq nov
(nnmaildir--update-nov nnmaildir--cur-server group
1119 (nnmaildir--cache-nov group article nov
)
1120 (setq num
(nnmaildir--art-num article
))
1121 (princ num nntp-server-buffer
)
1122 (insert "\t" (nnmaildir--nov-get-beg nov
) "\t"
1123 (nnmaildir--art-msgid article
) "\t"
1124 (nnmaildir--nov-get-mid nov
) "\tXref: nnmaildir "
1126 (princ num nntp-server-buffer
)
1127 (insert "\t" (nnmaildir--nov-get-end nov
) "\n"))))
1130 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1131 (if gname
(concat "No such group: " gname
) "No current group"))
1132 (throw 'return nil
))
1133 (nnmaildir--with-nntp-buffer
1135 (setq mlist
(nnmaildir--grp-mlist group
)
1136 nlist
(nnmaildir--grp-nlist group
)
1137 gname
(nnmaildir--grp-name group
)
1138 srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1139 dir
(nnmaildir--srvgrp-dir srv-dir gname
))
1142 ((and fetch-old
(not (numberp fetch-old
)))
1143 (nnmaildir--nlist-iterate nlist
'all insert-nov
))
1145 ((stringp (car articles
))
1148 (setq article
(nnmaildir--mlist-art mlist msgid
))
1149 (if article
(funcall insert-nov article
)))
1153 ;; Assume the article range list is sorted ascending
1154 (setq stop
(car articles
)
1155 start
(car (last articles
))
1156 stop
(if (numberp stop
) stop
(car stop
))
1157 start
(if (numberp start
) start
(cdr start
))
1158 stop
(- stop fetch-old
)
1159 stop
(if (< stop
1) 1 stop
)
1160 articles
(list (cons stop start
))))
1161 (nnmaildir--nlist-iterate nlist articles insert-nov
)))
1162 (sort-numeric-fields 1 (point-min) (point-max))
1165 (defun nnmaildir-request-article (num-msgid &optional gname server to-buffer
)
1166 (let ((group (nnmaildir--prepare server gname
))
1167 (case-fold-search t
)
1168 list article dir pgname deactivate-mark
)
1171 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1172 (if gname
(concat "No such group: " gname
) "No current group"))
1173 (throw 'return nil
))
1174 (if (numberp num-msgid
)
1175 (setq article
(nnmaildir--nlist-art group num-msgid
))
1176 (setq list
(nnmaildir--grp-mlist group
)
1177 article
(nnmaildir--mlist-art list num-msgid
))
1178 (if article
(setq num-msgid
(nnmaildir--art-num article
))
1182 (setq group
(symbol-value group-sym
)
1183 list
(nnmaildir--grp-mlist group
)
1184 article
(nnmaildir--mlist-art list num-msgid
))
1186 (setq num-msgid
(nnmaildir--art-num article
))
1187 (throw 'found nil
)))
1188 (nnmaildir--srv-groups nnmaildir--cur-server
))))
1190 (setf (nnmaildir--srv-error nnmaildir--cur-server
) "No such article")
1191 (throw 'return nil
)))
1192 (setq gname
(nnmaildir--grp-name group
)
1193 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1194 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1195 dir
(nnmaildir--srvgrp-dir dir gname
)
1196 dir
(if (nnmaildir--param pgname
'read-only
)
1197 (nnmaildir--new dir
) (nnmaildir--cur dir
))
1198 nnmaildir-article-file-name
1200 (nnmaildir--art-prefix article
)
1201 (nnmaildir--art-suffix article
)))
1202 (unless (file-exists-p nnmaildir-article-file-name
)
1203 (nnmaildir--expired-article group article
)
1204 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1205 "Article has expired")
1206 (throw 'return nil
))
1208 (set-buffer (or to-buffer nntp-server-buffer
))
1210 (nnheader-insert-file-contents nnmaildir-article-file-name
))
1211 (cons gname num-msgid
))))
1213 (defun nnmaildir-request-post (&optional server
)
1214 (let (message-required-mail-headers)
1215 (funcall message-send-mail-function
)))
1217 (defun nnmaildir-request-replace-article (number gname buffer
)
1218 (let ((group (nnmaildir--prepare nil gname
))
1219 (coding-system-for-write nnheader-file-coding-system
)
1220 (buffer-file-coding-system nil
)
1221 (file-coding-system-alist nil
)
1222 dir file article suffix tmpfile deactivate-mark
)
1225 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1226 (concat "No such group: " gname
))
1227 (throw 'return nil
))
1228 (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname
)
1230 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1231 (concat "Read-only group: " group
))
1232 (throw 'return nil
))
1233 (setq dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1234 dir
(nnmaildir--srvgrp-dir dir gname
)
1235 article
(nnmaildir--nlist-art group number
))
1237 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1238 (concat "No such article: " (number-to-string number
)))
1239 (throw 'return nil
))
1240 (setq suffix
(nnmaildir--art-suffix article
)
1241 file
(nnmaildir--art-prefix article
)
1242 tmpfile
(concat (nnmaildir--tmp dir
) file
))
1243 (when (file-exists-p tmpfile
)
1244 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1245 (concat "File exists: " tmpfile
))
1246 (throw 'return nil
))
1249 (write-region (point-min) (point-max) tmpfile nil
'no-message nil
1251 (unix-sync) ;; no fsync :(
1252 (rename-file tmpfile
(concat (nnmaildir--cur dir
) file suffix
) 'replace
)
1255 (defun nnmaildir-request-move-article (article gname server accept-form
1257 (let ((group (nnmaildir--prepare server gname
))
1258 pgname suffix result nnmaildir--file deactivate-mark
)
1261 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1262 (concat "No such group: " gname
))
1263 (throw 'return nil
))
1264 (setq gname
(nnmaildir--grp-name group
)
1265 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1266 article
(nnmaildir--nlist-art group article
))
1268 (setf (nnmaildir--srv-error nnmaildir--cur-server
) "No such article")
1269 (throw 'return nil
))
1270 (setq suffix
(nnmaildir--art-suffix article
)
1271 nnmaildir--file
(nnmaildir--srv-dir nnmaildir--cur-server
)
1272 nnmaildir--file
(nnmaildir--srvgrp-dir nnmaildir--file gname
)
1273 nnmaildir--file
(if (nnmaildir--param pgname
'read-only
)
1274 (nnmaildir--new nnmaildir--file
)
1275 (nnmaildir--cur nnmaildir--file
))
1276 nnmaildir--file
(concat nnmaildir--file
1277 (nnmaildir--art-prefix article
)
1279 (unless (file-exists-p nnmaildir--file
)
1280 (nnmaildir--expired-article group article
)
1281 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1282 "Article has expired")
1283 (throw 'return nil
))
1284 (nnmaildir--with-move-buffer
1286 (nnheader-insert-file-contents nnmaildir--file
)
1287 (setq result
(eval accept-form
)))
1288 (unless (or (null result
) (nnmaildir--param pgname
'read-only
))
1289 (nnmaildir--unlink nnmaildir--file
)
1290 (nnmaildir--expired-article group article
))
1293 (defun nnmaildir-request-accept-article (gname &optional server last
)
1294 (let ((group (nnmaildir--prepare server gname
))
1295 (coding-system-for-write nnheader-file-coding-system
)
1296 (buffer-file-coding-system nil
)
1297 (file-coding-system-alist nil
)
1298 srv-dir dir file time tmpfile curfile
24h article
)
1301 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1302 (concat "No such group: " gname
))
1303 (throw 'return nil
))
1304 (setq gname
(nnmaildir--grp-name group
))
1305 (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname
)
1307 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1308 (concat "Read-only group: " gname
))
1309 (throw 'return nil
))
1310 (setq srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1311 dir
(nnmaildir--srvgrp-dir srv-dir gname
)
1313 file
(format-time-string "%s." time
))
1314 (unless (string-equal nnmaildir--delivery-time file
)
1315 (setq nnmaildir--delivery-time file
1316 nnmaildir--delivery-count
0))
1317 (when (and (consp (cdr time
))
1318 (consp (cddr time
)))
1319 (setq file
(concat file
"M" (number-to-string (caddr time
)))))
1320 (setq file
(concat file nnmaildir--delivery-pid
)
1321 file
(concat file
"Q" (number-to-string nnmaildir--delivery-count
))
1322 file
(concat file
"." (nnmaildir--system-name))
1323 tmpfile
(concat (nnmaildir--tmp dir
) file
)
1324 curfile
(concat (nnmaildir--cur dir
) file
":2,"))
1325 (when (file-exists-p tmpfile
)
1326 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1327 (concat "File exists: " tmpfile
))
1328 (throw 'return nil
))
1329 (when (file-exists-p curfile
)
1330 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1331 (concat "File exists: " curfile
))
1332 (throw 'return nil
))
1333 (setq nnmaildir--delivery-count
(1+ nnmaildir--delivery-count
)
1334 24h
(run-with-timer 86400 nil
1336 (nnmaildir--unlink tmpfile
)
1337 (setf (nnmaildir--srv-error
1338 nnmaildir--cur-server
)
1339 "24-hour timer expired")
1340 (throw 'return nil
))))
1342 (add-name-to-file nnmaildir--file tmpfile
)
1344 (write-region (point-min) (point-max) tmpfile nil
'no-message nil
1346 (unix-sync))) ;; no fsync :(
1349 (add-name-to-file tmpfile curfile
)
1351 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1352 (concat "Error linking: " (prin1-to-string err
)))
1353 (nnmaildir--unlink tmpfile
)
1354 (throw 'return nil
)))
1355 (nnmaildir--unlink tmpfile
)
1356 (setq article
(make-nnmaildir--art :prefix file
:suffix
":2,"))
1357 (if (nnmaildir--grp-add-art nnmaildir--cur-server group article
)
1358 (cons gname
(nnmaildir--art-num article
))))))
1360 (defun nnmaildir-save-mail (group-art)
1363 (throw 'return nil
))
1364 (let (ga gname x groups nnmaildir--file deactivate-mark
)
1366 (goto-char (point-min))
1368 (while (looking-at "From ")
1369 (replace-match "X-From-Line: ")
1371 (setq groups
(nnmaildir--srv-groups nnmaildir--cur-server
)
1372 ga
(car group-art
) group-art
(cdr group-art
)
1374 (or (intern-soft gname groups
)
1375 (nnmaildir-request-create-group gname
)
1376 (throw 'return nil
)) ;; not that nnmail bothers to check :(
1377 (unless (nnmaildir-request-accept-article gname
)
1378 (throw 'return nil
))
1379 (setq nnmaildir--file
(nnmaildir--srv-dir nnmaildir--cur-server
)
1380 nnmaildir--file
(nnmaildir--srvgrp-dir nnmaildir--file gname
)
1381 x
(nnmaildir--prepare nil gname
)
1382 x
(nnmaildir--grp-nlist x
)
1384 nnmaildir--file
(concat nnmaildir--file
1385 (nnmaildir--art-prefix x
)
1386 (nnmaildir--art-suffix x
)))
1390 (setq gname
(car ga
))
1391 (and (or (intern-soft gname groups
)
1392 (nnmaildir-request-create-group gname
))
1393 (nnmaildir-request-accept-article gname
)
1397 (defun nnmaildir-active-number (gname)
1400 (defun nnmaildir-request-expire-articles (ranges &optional gname server force
)
1401 (let ((no-force (not force
))
1402 (group (nnmaildir--prepare server gname
))
1403 pgname time boundary bound-iter high low target dir nlist nlist2
1404 stop article didnt nnmaildir--file nnmaildir-article-file-name
1408 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1409 (if gname
(concat "No such group: " gname
) "No current group"))
1410 (throw 'return
(gnus-uncompress-range ranges
)))
1411 (setq gname
(nnmaildir--grp-name group
)
1412 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
))
1413 (if (nnmaildir--param pgname
'read-only
)
1414 (throw 'return
(gnus-uncompress-range ranges
)))
1415 (setq time
(nnmaildir--param pgname
'expire-age
))
1417 (setq time
(or (and nnmail-expiry-wait-function
1418 (funcall nnmail-expiry-wait-function gname
))
1419 nnmail-expiry-wait
))
1420 (if (eq time
'immediate
)
1423 (setq time
(* time
86400)))))
1425 (unless (integerp time
) ;; handle 'never
1426 (throw 'return
(gnus-uncompress-range ranges
)))
1427 (setq boundary
(current-time)
1428 high
(- (car boundary
) (/ time
65536))
1429 low
(- (cadr boundary
) (% time
65536)))
1431 (setq low
(+ low
65536)
1433 (setcar (cdr boundary
) low
)
1434 (setcar boundary high
))
1435 (setq dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1436 dir
(nnmaildir--srvgrp-dir dir gname
)
1437 dir
(nnmaildir--cur dir
)
1438 nlist
(nnmaildir--grp-nlist group
)
1439 ranges
(reverse ranges
))
1440 (nnmaildir--with-move-buffer
1441 (nnmaildir--nlist-iterate
1444 (setq nnmaildir--file
(nnmaildir--art-prefix article
)
1445 nnmaildir--file
(concat dir nnmaildir--file
1446 (nnmaildir--art-suffix article
))
1447 time
(file-attributes nnmaildir--file
))
1450 (nnmaildir--expired-article group article
))
1453 (setq time
(nth 5 time
)
1454 bound-iter boundary
)
1455 (while (and bound-iter time
1456 (= (car bound-iter
) (car time
)))
1457 (setq bound-iter
(cdr bound-iter
)
1459 (and bound-iter time
1460 (car-less-than-car bound-iter time
))))
1461 (setq didnt
(cons (nnmaildir--art-num article
) didnt
)))
1463 (setq nnmaildir-article-file-name nnmaildir--file
1464 target
(if force nil
1467 (nnmaildir--param pgname
'expire-group
)))))
1468 (when (and (stringp target
)
1469 (not (string-equal target pgname
))) ;; Move it.
1471 (nnheader-insert-file-contents nnmaildir--file
)
1472 (gnus-request-accept-article target nil nil
'no-encode
))
1473 (if (equal target pgname
)
1475 (setq didnt
(cons (nnmaildir--art-num article
) didnt
))
1476 (nnmaildir--unlink nnmaildir--file
)
1477 (nnmaildir--expired-article group article
))))))
1481 (defun nnmaildir-request-set-mark (gname actions
&optional server
)
1482 (let ((group (nnmaildir--prepare server gname
))
1483 (coding-system-for-write nnheader-file-coding-system
)
1484 (buffer-file-coding-system nil
)
1485 (file-coding-system-alist nil
)
1486 del-mark del-action add-action set-action marksdir markfile nlist
1487 ranges begin end article all-marks todo-marks did-marks mdir mfile
1488 pgname ls permarkfile deactivate-mark
)
1491 (setq mfile
(nnmaildir--subdir marksdir
(symbol-name mark
))
1492 mfile
(concat mfile
(nnmaildir--art-prefix article
)))
1493 (nnmaildir--unlink mfile
))
1494 del-action
(lambda (article) (mapcar del-mark todo-marks
))
1499 (setq mdir
(nnmaildir--subdir marksdir
(symbol-name mark
))
1500 permarkfile
(concat mdir
":")
1501 mfile
(concat mdir
(nnmaildir--art-prefix article
)))
1502 (unless (memq mark did-marks
)
1503 (setq did-marks
(cons mark did-marks
))
1504 (nnmaildir--mkdir mdir
)
1505 (unless (file-attributes permarkfile
)
1507 (add-name-to-file markfile permarkfile
)
1509 ;; AFS can't make hard links in separate directories
1510 (write-region "" nil permarkfile nil
'no-message
)))))
1511 (unless (file-exists-p mfile
)
1512 (add-name-to-file permarkfile mfile
)))
1514 set-action
(lambda (article)
1515 (funcall add-action
)
1516 (mapcar (lambda (mark)
1517 (unless (memq mark todo-marks
)
1518 (funcall del-mark mark
)))
1522 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1523 (concat "No such group: " gname
))
1524 (mapcar (lambda (action)
1525 (setq ranges
(gnus-range-add ranges
(car action
))))
1527 (throw 'return ranges
))
1528 (setq nlist
(nnmaildir--grp-nlist group
)
1529 marksdir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1530 marksdir
(nnmaildir--srvgrp-dir marksdir gname
)
1531 marksdir
(nnmaildir--nndir marksdir
)
1532 markfile
(concat marksdir
"markfile")
1533 marksdir
(nnmaildir--marks-dir marksdir
)
1534 gname
(nnmaildir--grp-name group
)
1535 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1536 ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
)
1537 all-marks
(funcall ls marksdir nil
"\\`[^.]" 'nosort
)
1538 all-marks
(mapcar 'intern all-marks
))
1541 (setq ranges
(car action
)
1542 todo-marks
(caddr action
))
1543 (mapcar (lambda (mark) (add-to-list 'all-marks mark
)) todo-marks
)
1544 (if (numberp (cdr ranges
)) (setq ranges
(list ranges
)))
1545 (nnmaildir--nlist-iterate nlist ranges
1546 (cond ((eq 'del
(cadr action
)) del-action
)
1547 ((eq 'add
(cadr action
)) add-action
)
1552 (defun nnmaildir-close-group (gname &optional server
)
1553 (let ((group (nnmaildir--prepare server gname
))
1554 pgname ls dir msgdir files flist dirs
)
1557 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1558 (concat "No such group: " gname
))
1560 (setq pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1561 ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
)
1562 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1563 dir
(nnmaildir--srvgrp-dir dir gname
)
1564 msgdir
(if (nnmaildir--param pgname
'read-only
)
1565 (nnmaildir--new dir
) (nnmaildir--cur dir
))
1566 dir
(nnmaildir--nndir dir
)
1567 dirs
(cons (nnmaildir--nov-dir dir
)
1568 (funcall ls
(nnmaildir--marks-dir dir
) 'full
"\\`[^.]"
1572 (cons dir
(funcall ls dir nil
"\\`[^.]" 'nosort
)))
1574 files
(funcall ls msgdir nil
"\\`[^.]" 'nosort
)
1575 flist
(nnmaildir--up2-1 (length files
))
1576 flist
(make-vector flist
0))
1580 (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file
)
1581 (intern (match-string 1 file
) flist
))
1585 (setq files
(cdr dir
)
1586 dir
(file-name-as-directory (car dir
)))
1589 (unless (or (intern-soft file flist
) (string= file
":"))
1590 (setq file
(concat dir file
))
1591 (delete-file file
)))
1596 (defun nnmaildir-close-server (&optional server
)
1597 (let (flist ls dirs dir files file x
)
1598 (nnmaildir--prepare server nil
)
1599 (when nnmaildir--cur-server
1600 (setq server nnmaildir--cur-server
1601 nnmaildir--cur-server nil
)
1602 (unintern (nnmaildir--srv-address server
) nnmaildir--servers
)))
1605 (defun nnmaildir-request-close ()
1606 (let (servers buffer
)
1607 (mapatoms (lambda (server)
1608 (setq servers
(cons (symbol-name server
) servers
)))
1610 (mapcar 'nnmaildir-close-server servers
)
1611 (setq buffer
(get-buffer " *nnmaildir work*"))
1612 (if buffer
(kill-buffer buffer
))
1613 (setq buffer
(get-buffer " *nnmaildir nov*"))
1614 (if buffer
(kill-buffer buffer
))
1615 (setq buffer
(get-buffer " *nnmaildir move*"))
1616 (if buffer
(kill-buffer buffer
)))
1619 (provide 'nnmaildir
)
1622 ;; indent-tabs-mode: t
1626 ;;; arch-tag: 0c4e44cd-dfde-4040-888e-5597ec771849
1627 ;;; nnmaildir.el ends here