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))
802 (remove-if (lambda (dir)
803 (and (>= (length dir) (length target-prefix))
804 (string= (substring dir 0 (length target-prefix))
807 seen (nnmaildir--up2-1 (length dirs))
808 seen (make-vector seen 0))
811 (if (nnmaildir--scan grp-dir scan-group groups method srv-dir
813 (intern grp-dir seen)))
816 (mapatoms (lambda (group)
817 (setq group (symbol-name group))
818 (unless (intern-soft group seen)
819 (setq x (cons group x))))
821 (mapcar (lambda (grp) (unintern grp groups)) x)
822 (setf (nnmaildir--srv-mtime nnmaildir--cur-server)
823 (nth 5 (file-attributes srv-dir))))
825 (nnmaildir--srv-gnm nnmaildir--cur-server)
826 (nnmail-get-new-mail 'nnmaildir nil nil))))))
829 (defun nnmaildir-request-list (&optional server)
830 (nnmaildir-request-scan 'find-new-groups server)
831 (let (pgname ro deactivate-mark)
832 (nnmaildir--prepare server nil)
833 (nnmaildir--with-nntp-buffer
835 (mapatoms (lambda (group)
836 (setq pgname (symbol-name group)
837 pgname (nnmaildir--pgname nnmaildir--cur-server pgname)
838 group (symbol-value group)
839 ro (nnmaildir--param pgname 'read-only))
840 (insert (nnmaildir--grp-name group) " ")
841 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
844 (princ (nnmaildir--grp-min group) nntp-server-buffer)
845 (insert " " (if ro "n" "y") "\n"))
846 (nnmaildir--srv-groups nnmaildir--cur-server))))
849 (defun nnmaildir-request-newgroups (date &optional server)
850 (nnmaildir-request-list server))
852 (defun nnmaildir-retrieve-groups (groups &optional server)
853 (let (group deactivate-mark)
854 (nnmaildir--prepare server nil)
855 (nnmaildir--with-nntp-buffer
859 (setq group (nnmaildir--prepare nil gname))
860 (if (null group) (insert "411 no such news group\n")
862 (princ (nnmaildir--grp-count group) nntp-server-buffer)
864 (princ (nnmaildir--grp-min group) nntp-server-buffer)
866 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
868 (insert " " gname "\n")))
872 (defun nnmaildir-request-update-info (gname info &optional server)
873 (let ((group (nnmaildir--prepare server gname))
874 pgname flist always-marks never-marks old-marks dotfile num dir
875 markdirs marks mark ranges markdir article read end new-marks ls
876 old-mmth new-mmth mtime mark-sym existing missing deactivate-mark)
879 (setf (nnmaildir--srv-error nnmaildir--cur-server)
880 (concat "No such group: " gname))
882 (setq gname (nnmaildir--grp-name group)
883 pgname (nnmaildir--pgname nnmaildir--cur-server gname)
884 flist (nnmaildir--grp-flist group))
885 (when (zerop (nnmaildir--grp-count group))
886 (gnus-info-set-read info nil)
887 (gnus-info-set-marks info nil 'extend)
888 (throw 'return info))
889 (setq old-marks (cons 'read (gnus-info-read info))
890 old-marks (cons old-marks (gnus-info-marks info))
891 always-marks (nnmaildir--param pgname 'always-marks)
892 never-marks (nnmaildir--param pgname 'never-marks)
893 existing (nnmaildir--grp-nlist group)
894 existing (mapcar 'car existing)
895 existing (nreverse existing)
896 existing (gnus-compress-sequence existing 'always-list)
897 missing (list (cons 1 (nnmaildir--group-maxnum
898 nnmaildir--cur-server group)))
899 missing (gnus-range-difference missing existing)
900 dir (nnmaildir--srv-dir nnmaildir--cur-server)
901 dir (nnmaildir--srvgrp-dir dir gname)
902 dir (nnmaildir--nndir dir)
903 dir (nnmaildir--marks-dir dir)
904 ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
905 markdirs (funcall ls dir nil "\\`[^.]" 'nosort)
906 new-mmth (nnmaildir--up2-1 (length markdirs))
907 new-mmth (make-vector new-mmth 0)
908 old-mmth (nnmaildir--grp-mmth group))
911 (setq markdir (nnmaildir--subdir dir mark)
912 mark-sym (intern mark)
915 (if (memq mark-sym never-marks) (throw 'got-ranges nil))
916 (when (memq mark-sym always-marks)
917 (setq ranges existing)
918 (throw 'got-ranges nil))
919 (setq mtime (nth 5 (file-attributes markdir)))
920 (set (intern mark new-mmth) mtime)
921 (when (equal mtime (symbol-value (intern-soft mark old-mmth)))
922 (setq ranges (assq mark-sym old-marks))
923 (if ranges (setq ranges (cdr ranges)))
924 (throw 'got-ranges nil))
927 (setq article (nnmaildir--flist-art flist prefix))
930 (gnus-add-to-range ranges
931 `(,(nnmaildir--art-num article))))))
932 (funcall ls markdir nil "\\`[^.]" 'nosort)))
933 (if (eq mark-sym 'read) (setq read ranges)
934 (if ranges (setq marks (cons (cons mark-sym ranges) marks)))))
936 (gnus-info-set-read info (gnus-range-add read missing))
937 (gnus-info-set-marks info marks 'extend)
938 (setf (nnmaildir--grp-mmth group) new-mmth)
941 (defun nnmaildir-request-group (gname &optional server fast)
942 (let ((group (nnmaildir--prepare server gname))
946 ;; (insert "411 no such news group\n")
947 (setf (nnmaildir--srv-error nnmaildir--cur-server)
948 (concat "No such group: " gname))
950 (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) group)
951 (if fast (throw 'return t))
952 (nnmaildir--with-nntp-buffer
955 (princ (nnmaildir--grp-count group) nntp-server-buffer)
957 (princ (nnmaildir--grp-min group) nntp-server-buffer)
959 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
961 (insert " " gname "\n")
964 (defun nnmaildir-request-create-group (gname &optional server args)
965 (nnmaildir--prepare server nil)
967 (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server))
969 (when (zerop (length gname))
970 (setf (nnmaildir--srv-error nnmaildir--cur-server)
971 "Invalid (empty) group name")
973 (when (eq (aref "." 0) (aref gname 0))
974 (setf (nnmaildir--srv-error nnmaildir--cur-server)
975 "Group names may not start with \".\"")
977 (when (save-match-data (string-match "[\0/\t]" gname))
978 (setf (nnmaildir--srv-error nnmaildir--cur-server)
979 (concat "Illegal characters (null, tab, or /) in group name: "
982 (setq groups (nnmaildir--srv-groups nnmaildir--cur-server))
983 (when (intern-soft gname groups)
984 (setf (nnmaildir--srv-error nnmaildir--cur-server)
985 (concat "Group already exists: " gname))
987 (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server))
988 (if (file-name-absolute-p target-prefix)
989 (setq dir (expand-file-name target-prefix))
991 dir (file-truename dir)
992 dir (concat dir target-prefix)))
993 (setq dir (nnmaildir--subdir dir gname))
994 (nnmaildir--mkdir dir)
995 (nnmaildir--mkdir (nnmaildir--tmp dir))
996 (nnmaildir--mkdir (nnmaildir--new dir))
997 (nnmaildir--mkdir (nnmaildir--cur dir))
998 (unless (string= target-prefix "")
999 (make-symbolic-link (concat target-prefix gname)
1000 (concat srv-dir gname)))
1001 (nnmaildir-request-scan 'find-new-groups))))
1003 (defun nnmaildir-request-rename-group (gname new-name &optional server)
1004 (let ((group (nnmaildir--prepare server gname))
1005 (coding-system-for-write nnheader-file-coding-system)
1006 (buffer-file-coding-system nil)
1007 (file-coding-system-alist nil)
1011 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1012 (concat "No such group: " gname))
1013 (throw 'return nil))
1014 (when (zerop (length new-name))
1015 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1016 "Invalid (empty) group name")
1017 (throw 'return nil))
1018 (when (eq (aref "." 0) (aref new-name 0))
1019 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1020 "Group names may not start with \".\"")
1021 (throw 'return nil))
1022 (when (save-match-data (string-match "[\0/\t]" new-name))
1023 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1024 (concat "Illegal characters (null, tab, or /) in group name: "
1026 (throw 'return nil))
1027 (if (string-equal gname new-name) (throw 'return t))
1028 (when (intern-soft new-name
1029 (nnmaildir--srv-groups nnmaildir--cur-server))
1030 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1031 (concat "Group already exists: " new-name))
1032 (throw 'return nil))
1033 (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server))
1035 (rename-file (concat srv-dir gname)
1036 (concat srv-dir new-name))
1038 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1039 (concat "Error renaming link: " (prin1-to-string err)))
1040 (throw 'return nil)))
1041 (setq x (nnmaildir--srv-groups nnmaildir--cur-server)
1042 groups (make-vector (length x) 0))
1043 (mapatoms (lambda (sym)
1044 (unless (eq (symbol-value sym) group)
1045 (set (intern (symbol-name sym) groups)
1046 (symbol-value sym))))
1048 (setq group (copy-sequence group))
1049 (setf (nnmaildir--grp-name group) new-name)
1050 (set (intern new-name groups) group)
1051 (setf (nnmaildir--srv-groups nnmaildir--cur-server) groups)
1054 (defun nnmaildir-request-delete-group (gname force &optional server)
1055 (let ((group (nnmaildir--prepare server gname))
1056 pgname grp-dir target dir ls deactivate-mark)
1059 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1060 (concat "No such group: " gname))
1061 (throw 'return nil))
1062 (setq gname (nnmaildir--grp-name group)
1063 pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1064 grp-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1065 target (car (file-attributes (concat grp-dir gname)))
1066 grp-dir (nnmaildir--srvgrp-dir grp-dir gname))
1067 (unless (or force (stringp target))
1068 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1069 (concat "Not a symlink: " gname))
1070 (throw 'return nil))
1071 (if (eq group (nnmaildir--srv-curgrp nnmaildir--cur-server))
1072 (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) nil))
1073 (unintern gname (nnmaildir--srv-groups nnmaildir--cur-server))
1076 (setq grp-dir (directory-file-name grp-dir))
1077 (nnmaildir--unlink grp-dir))
1078 (setq ls (nnmaildir--group-ls nnmaildir--cur-server pgname))
1079 (if (nnmaildir--param pgname 'read-only)
1080 (progn (delete-directory (nnmaildir--tmp grp-dir))
1081 (nnmaildir--unlink (nnmaildir--new grp-dir))
1082 (delete-directory (nnmaildir--cur grp-dir)))
1083 (nnmaildir--delete-dir-files (nnmaildir--tmp grp-dir) ls)
1084 (nnmaildir--delete-dir-files (nnmaildir--new grp-dir) ls)
1085 (nnmaildir--delete-dir-files (nnmaildir--cur grp-dir) ls))
1086 (setq dir (nnmaildir--nndir grp-dir))
1087 (mapcar (lambda (subdir) (nnmaildir--delete-dir-files subdir ls))
1088 `(,(nnmaildir--nov-dir dir) ,(nnmaildir--num-dir dir)
1089 ,@(funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]"
1091 (setq dir (nnmaildir--nndir grp-dir))
1092 (nnmaildir--unlink (concat dir "markfile"))
1093 (nnmaildir--unlink (concat dir "markfile{new}"))
1094 (delete-directory (nnmaildir--marks-dir dir))
1095 (delete-directory dir)
1096 (if (not (stringp target))
1097 (delete-directory grp-dir)
1098 (setq grp-dir (directory-file-name grp-dir)
1100 (unless (eq (aref "/" 0) (aref dir 0))
1101 (setq dir (concat (file-truename
1102 (nnmaildir--srv-dir nnmaildir--cur-server))
1104 (delete-directory dir)
1105 (nnmaildir--unlink grp-dir)))
1108 (defun nnmaildir-retrieve-headers (articles &optional gname server fetch-old)
1109 (let ((group (nnmaildir--prepare server gname))
1110 srv-dir dir nlist mlist article num start stop nov nlist2 insert-nov
1114 (setq nov (nnmaildir--update-nov nnmaildir--cur-server group
1117 (nnmaildir--cache-nov group article nov)
1118 (setq num (nnmaildir--art-num article))
1119 (princ num nntp-server-buffer)
1120 (insert "\t" (nnmaildir--nov-get-beg nov) "\t"
1121 (nnmaildir--art-msgid article) "\t"
1122 (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir "
1124 (princ num nntp-server-buffer)
1125 (insert "\t" (nnmaildir--nov-get-end nov) "\n"))))
1128 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1129 (if gname (concat "No such group: " gname) "No current group"))
1130 (throw 'return nil))
1131 (nnmaildir--with-nntp-buffer
1133 (setq mlist (nnmaildir--grp-mlist group)
1134 nlist (nnmaildir--grp-nlist group)
1135 gname (nnmaildir--grp-name group)
1136 srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1137 dir (nnmaildir--srvgrp-dir srv-dir gname))
1140 ((and fetch-old (not (numberp fetch-old)))
1141 (nnmaildir--nlist-iterate nlist 'all insert-nov))
1143 ((stringp (car articles))
1146 (setq article (nnmaildir--mlist-art mlist msgid))
1147 (if article (funcall insert-nov article)))
1151 ;; Assume the article range list is sorted ascending
1152 (setq stop (car articles)
1153 start (car (last articles))
1154 stop (if (numberp stop) stop (car stop))
1155 start (if (numberp start) start (cdr start))
1156 stop (- stop fetch-old)
1157 stop (if (< stop 1) 1 stop)
1158 articles (list (cons stop start))))
1159 (nnmaildir--nlist-iterate nlist articles insert-nov)))
1160 (sort-numeric-fields 1 (point-min) (point-max))
1163 (defun nnmaildir-request-article (num-msgid &optional gname server to-buffer)
1164 (let ((group (nnmaildir--prepare server gname))
1165 (case-fold-search t)
1166 list article dir pgname deactivate-mark)
1169 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1170 (if gname (concat "No such group: " gname) "No current group"))
1171 (throw 'return nil))
1172 (if (numberp num-msgid)
1173 (setq article (nnmaildir--nlist-art group num-msgid))
1174 (setq list (nnmaildir--grp-mlist group)
1175 article (nnmaildir--mlist-art list num-msgid))
1176 (if article (setq num-msgid (nnmaildir--art-num article))
1180 (setq group (symbol-value group-sym)
1181 list (nnmaildir--grp-mlist group)
1182 article (nnmaildir--mlist-art list num-msgid))
1184 (setq num-msgid (nnmaildir--art-num article))
1185 (throw 'found nil)))
1186 (nnmaildir--srv-groups nnmaildir--cur-server))))
1188 (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
1189 (throw 'return nil)))
1190 (setq gname (nnmaildir--grp-name group)
1191 pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1192 dir (nnmaildir--srv-dir nnmaildir--cur-server)
1193 dir (nnmaildir--srvgrp-dir dir gname)
1194 dir (if (nnmaildir--param pgname 'read-only)
1195 (nnmaildir--new dir) (nnmaildir--cur dir))
1196 nnmaildir-article-file-name
1198 (nnmaildir--art-prefix article)
1199 (nnmaildir--art-suffix article)))
1200 (unless (file-exists-p nnmaildir-article-file-name)
1201 (nnmaildir--expired-article group article)
1202 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1203 "Article has expired")
1204 (throw 'return nil))
1206 (set-buffer (or to-buffer nntp-server-buffer))
1208 (nnheader-insert-file-contents nnmaildir-article-file-name))
1209 (cons gname num-msgid))))
1211 (defun nnmaildir-request-post (&optional server)
1212 (let (message-required-mail-headers)
1213 (funcall message-send-mail-function)))
1215 (defun nnmaildir-request-replace-article (number gname buffer)
1216 (let ((group (nnmaildir--prepare nil gname))
1217 (coding-system-for-write nnheader-file-coding-system)
1218 (buffer-file-coding-system nil)
1219 (file-coding-system-alist nil)
1220 dir file article suffix tmpfile deactivate-mark)
1223 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1224 (concat "No such group: " gname))
1225 (throw 'return nil))
1226 (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
1228 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1229 (concat "Read-only group: " group))
1230 (throw 'return nil))
1231 (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
1232 dir (nnmaildir--srvgrp-dir dir gname)
1233 article (nnmaildir--nlist-art group number))
1235 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1236 (concat "No such article: " (number-to-string number)))
1237 (throw 'return nil))
1238 (setq suffix (nnmaildir--art-suffix article)
1239 file (nnmaildir--art-prefix article)
1240 tmpfile (concat (nnmaildir--tmp dir) file))
1241 (when (file-exists-p tmpfile)
1242 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1243 (concat "File exists: " tmpfile))
1244 (throw 'return nil))
1247 (write-region (point-min) (point-max) tmpfile nil 'no-message nil
1249 (unix-sync) ;; no fsync :(
1250 (rename-file tmpfile (concat (nnmaildir--cur dir) file suffix) 'replace)
1253 (defun nnmaildir-request-move-article (article gname server accept-form
1255 (let ((group (nnmaildir--prepare server gname))
1256 pgname suffix result nnmaildir--file deactivate-mark)
1259 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1260 (concat "No such group: " gname))
1261 (throw 'return nil))
1262 (setq gname (nnmaildir--grp-name group)
1263 pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1264 article (nnmaildir--nlist-art group article))
1266 (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
1267 (throw 'return nil))
1268 (setq suffix (nnmaildir--art-suffix article)
1269 nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
1270 nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname)
1271 nnmaildir--file (if (nnmaildir--param pgname 'read-only)
1272 (nnmaildir--new nnmaildir--file)
1273 (nnmaildir--cur nnmaildir--file))
1274 nnmaildir--file (concat nnmaildir--file
1275 (nnmaildir--art-prefix article)
1277 (unless (file-exists-p nnmaildir--file)
1278 (nnmaildir--expired-article group article)
1279 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1280 "Article has expired")
1281 (throw 'return nil))
1282 (nnmaildir--with-move-buffer
1284 (nnheader-insert-file-contents nnmaildir--file)
1285 (setq result (eval accept-form)))
1286 (unless (or (null result) (nnmaildir--param pgname 'read-only))
1287 (nnmaildir--unlink nnmaildir--file)
1288 (nnmaildir--expired-article group article))
1291 (defun nnmaildir-request-accept-article (gname &optional server last)
1292 (let ((group (nnmaildir--prepare server gname))
1293 (coding-system-for-write nnheader-file-coding-system)
1294 (buffer-file-coding-system nil)
1295 (file-coding-system-alist nil)
1296 srv-dir dir file time tmpfile curfile 24h article)
1299 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1300 (concat "No such group: " gname))
1301 (throw 'return nil))
1302 (setq gname (nnmaildir--grp-name group))
1303 (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
1305 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1306 (concat "Read-only group: " gname))
1307 (throw 'return nil))
1308 (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1309 dir (nnmaildir--srvgrp-dir srv-dir gname)
1311 file (format-time-string "%s." time))
1312 (unless (string-equal nnmaildir--delivery-time file)
1313 (setq nnmaildir--delivery-time file
1314 nnmaildir--delivery-count 0))
1315 (when (and (consp (cdr time))
1316 (consp (cddr time)))
1317 (setq file (concat file "M" (number-to-string (caddr time)))))
1318 (setq file (concat file nnmaildir--delivery-pid)
1319 file (concat file "Q" (number-to-string nnmaildir--delivery-count))
1320 file (concat file "." (nnmaildir--system-name))
1321 tmpfile (concat (nnmaildir--tmp dir) file)
1322 curfile (concat (nnmaildir--cur dir) file ":2,"))
1323 (when (file-exists-p tmpfile)
1324 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1325 (concat "File exists: " tmpfile))
1326 (throw 'return nil))
1327 (when (file-exists-p curfile)
1328 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1329 (concat "File exists: " curfile))
1330 (throw 'return nil))
1331 (setq nnmaildir--delivery-count (1+ nnmaildir--delivery-count)
1332 24h (run-with-timer 86400 nil
1334 (nnmaildir--unlink tmpfile)
1335 (setf (nnmaildir--srv-error
1336 nnmaildir--cur-server)
1337 "24-hour timer expired")
1338 (throw 'return nil))))
1340 (add-name-to-file nnmaildir--file tmpfile)
1342 (write-region (point-min) (point-max) tmpfile nil 'no-message nil
1344 (unix-sync))) ;; no fsync :(
1347 (add-name-to-file tmpfile curfile)
1349 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1350 (concat "Error linking: " (prin1-to-string err)))
1351 (nnmaildir--unlink tmpfile)
1352 (throw 'return nil)))
1353 (nnmaildir--unlink tmpfile)
1354 (setq article (make-nnmaildir--art :prefix file :suffix ":2,"))
1355 (if (nnmaildir--grp-add-art nnmaildir--cur-server group article)
1356 (cons gname (nnmaildir--art-num article))))))
1358 (defun nnmaildir-save-mail (group-art)
1361 (throw 'return nil))
1362 (let (ga gname x groups nnmaildir--file deactivate-mark)
1364 (goto-char (point-min))
1366 (while (looking-at "From ")
1367 (replace-match "X-From-Line: ")
1369 (setq groups (nnmaildir--srv-groups nnmaildir--cur-server)
1370 ga (car group-art) group-art (cdr group-art)
1372 (or (intern-soft gname groups)
1373 (nnmaildir-request-create-group gname)
1374 (throw 'return nil)) ;; not that nnmail bothers to check :(
1375 (unless (nnmaildir-request-accept-article gname)
1376 (throw 'return nil))
1377 (setq nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
1378 nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname)
1379 x (nnmaildir--prepare nil gname)
1380 x (nnmaildir--grp-nlist x)
1382 nnmaildir--file (concat nnmaildir--file
1383 (nnmaildir--art-prefix x)
1384 (nnmaildir--art-suffix x)))
1388 (setq gname (car ga))
1389 (and (or (intern-soft gname groups)
1390 (nnmaildir-request-create-group gname))
1391 (nnmaildir-request-accept-article gname)
1395 (defun nnmaildir-active-number (gname)
1398 (defun nnmaildir-request-expire-articles (ranges &optional gname server force)
1399 (let ((no-force (not force))
1400 (group (nnmaildir--prepare server gname))
1401 pgname time boundary bound-iter high low target dir nlist nlist2
1402 stop article didnt nnmaildir--file nnmaildir-article-file-name
1406 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1407 (if gname (concat "No such group: " gname) "No current group"))
1408 (throw 'return (gnus-uncompress-range ranges)))
1409 (setq gname (nnmaildir--grp-name group)
1410 pgname (nnmaildir--pgname nnmaildir--cur-server gname))
1411 (if (nnmaildir--param pgname 'read-only)
1412 (throw 'return (gnus-uncompress-range ranges)))
1413 (setq time (nnmaildir--param pgname 'expire-age))
1415 (setq time (or (and nnmail-expiry-wait-function
1416 (funcall nnmail-expiry-wait-function gname))
1417 nnmail-expiry-wait))
1418 (if (eq time 'immediate)
1421 (setq time (* time 86400)))))
1423 (unless (integerp time) ;; handle 'never
1424 (throw 'return (gnus-uncompress-range ranges)))
1425 (setq boundary (current-time)
1426 high (- (car boundary) (/ time 65536))
1427 low (- (cadr boundary) (% time 65536)))
1429 (setq low (+ low 65536)
1431 (setcar (cdr boundary) low)
1432 (setcar boundary high))
1433 (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
1434 dir (nnmaildir--srvgrp-dir dir gname)
1435 dir (nnmaildir--cur dir)
1436 nlist (nnmaildir--grp-nlist group)
1437 ranges (reverse ranges))
1438 (nnmaildir--with-move-buffer
1439 (nnmaildir--nlist-iterate
1442 (setq nnmaildir--file (nnmaildir--art-prefix article)
1443 nnmaildir--file (concat dir nnmaildir--file
1444 (nnmaildir--art-suffix article))
1445 time (file-attributes nnmaildir--file))
1448 (nnmaildir--expired-article group article))
1451 (setq time (nth 5 time)
1452 bound-iter boundary)
1453 (while (and bound-iter time
1454 (= (car bound-iter) (car time)))
1455 (setq bound-iter (cdr bound-iter)
1457 (and bound-iter time
1458 (car-less-than-car bound-iter time))))
1459 (setq didnt (cons (nnmaildir--art-num article) didnt)))
1461 (setq nnmaildir-article-file-name nnmaildir--file
1462 target (if force nil
1465 (nnmaildir--param pgname 'expire-group)))))
1466 (when (and (stringp target)
1467 (not (string-equal target pgname))) ;; Move it.
1469 (nnheader-insert-file-contents nnmaildir--file)
1470 (gnus-request-accept-article target nil nil 'no-encode))
1471 (if (equal target pgname)
1473 (setq didnt (cons (nnmaildir--art-num article) didnt))
1474 (nnmaildir--unlink nnmaildir--file)
1475 (nnmaildir--expired-article group article))))))
1479 (defun nnmaildir-request-set-mark (gname actions &optional server)
1480 (let ((group (nnmaildir--prepare server gname))
1481 (coding-system-for-write nnheader-file-coding-system)
1482 (buffer-file-coding-system nil)
1483 (file-coding-system-alist nil)
1484 del-mark del-action add-action set-action marksdir markfile nlist
1485 ranges begin end article all-marks todo-marks did-marks mdir mfile
1486 pgname ls permarkfile deactivate-mark)
1489 (setq mfile (nnmaildir--subdir marksdir (symbol-name mark))
1490 mfile (concat mfile (nnmaildir--art-prefix article)))
1491 (nnmaildir--unlink mfile))
1492 del-action (lambda (article) (mapcar del-mark todo-marks))
1497 (setq mdir (nnmaildir--subdir marksdir (symbol-name mark))
1498 permarkfile (concat mdir ":")
1499 mfile (concat mdir (nnmaildir--art-prefix article)))
1500 (unless (memq mark did-marks)
1501 (setq did-marks (cons mark did-marks))
1502 (nnmaildir--mkdir mdir)
1503 (unless (file-attributes permarkfile)
1505 (add-name-to-file markfile permarkfile)
1507 ;; AFS can't make hard links in separate directories
1508 (write-region "" nil permarkfile nil 'no-message)))))
1509 (unless (file-exists-p mfile)
1510 (add-name-to-file permarkfile mfile)))
1512 set-action (lambda (article)
1513 (funcall add-action)
1514 (mapcar (lambda (mark)
1515 (unless (memq mark todo-marks)
1516 (funcall del-mark mark)))
1520 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1521 (concat "No such group: " gname))
1522 (mapcar (lambda (action)
1523 (setq ranges (gnus-range-add ranges (car action))))
1525 (throw 'return ranges))
1526 (setq nlist (nnmaildir--grp-nlist group)
1527 marksdir (nnmaildir--srv-dir nnmaildir--cur-server)
1528 marksdir (nnmaildir--srvgrp-dir marksdir gname)
1529 marksdir (nnmaildir--nndir marksdir)
1530 markfile (concat marksdir "markfile")
1531 marksdir (nnmaildir--marks-dir marksdir)
1532 gname (nnmaildir--grp-name group)
1533 pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1534 ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1535 all-marks (funcall ls marksdir nil "\\`[^.]" 'nosort)
1536 all-marks (mapcar 'intern all-marks))
1539 (setq ranges (car action)
1540 todo-marks (caddr action))
1541 (mapcar (lambda (mark) (add-to-list 'all-marks mark)) todo-marks)
1542 (if (numberp (cdr ranges)) (setq ranges (list ranges)))
1543 (nnmaildir--nlist-iterate nlist ranges
1544 (cond ((eq 'del (cadr action)) del-action)
1545 ((eq 'add (cadr action)) add-action)
1550 (defun nnmaildir-close-group (gname &optional server)
1551 (let ((group (nnmaildir--prepare server gname))
1552 pgname ls dir msgdir files flist dirs)
1555 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1556 (concat "No such group: " gname))
1558 (setq pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1559 ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1560 dir (nnmaildir--srv-dir nnmaildir--cur-server)
1561 dir (nnmaildir--srvgrp-dir dir gname)
1562 msgdir (if (nnmaildir--param pgname 'read-only)
1563 (nnmaildir--new dir) (nnmaildir--cur dir))
1564 dir (nnmaildir--nndir dir)
1565 dirs (cons (nnmaildir--nov-dir dir)
1566 (funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]"
1570 (cons dir (funcall ls dir nil "\\`[^.]" 'nosort)))
1572 files (funcall ls msgdir nil "\\`[^.]" 'nosort)
1573 flist (nnmaildir--up2-1 (length files))
1574 flist (make-vector flist 0))
1578 (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file)
1579 (intern (match-string 1 file) flist))
1583 (setq files (cdr dir)
1584 dir (file-name-as-directory (car dir)))
1587 (unless (or (intern-soft file flist) (string= file ":"))
1588 (setq file (concat dir file))
1589 (delete-file file)))
1594 (defun nnmaildir-close-server (&optional server)
1595 (let (flist ls dirs dir files file x)
1596 (nnmaildir--prepare server nil)
1597 (when nnmaildir--cur-server
1598 (setq server nnmaildir--cur-server
1599 nnmaildir--cur-server nil)
1600 (unintern (nnmaildir--srv-address server) nnmaildir--servers)))
1603 (defun nnmaildir-request-close ()
1604 (let (servers buffer)
1605 (mapatoms (lambda (server)
1606 (setq servers (cons (symbol-name server) servers)))
1608 (mapcar 'nnmaildir-close-server servers)
1609 (setq buffer (get-buffer " *nnmaildir work*"))
1610 (if buffer (kill-buffer buffer))
1611 (setq buffer (get-buffer " *nnmaildir nov*"))
1612 (if buffer (kill-buffer buffer))
1613 (setq buffer (get-buffer " *nnmaildir move*"))
1614 (if buffer (kill-buffer buffer)))
1617 (provide 'nnmaildir)
1620 ;; indent-tabs-mode: t
1624 ;;; nnmaildir.el ends here