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 in the maildir(5) man page from qmail
26 ;; (available at <URL:http://multivac.cwru.edu./prj/maildir.5>) and at
27 ;; <URL:http://cr.yp.to/proto/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., stale NOV data is
32 ;; ignored; no need for -generate-nov-databases.
33 ;; * Perfect reliability: [C-g] will never corrupt its data in memory,
34 ;; and SIGKILL will never corrupt its data in the filesystem.
35 ;; * We use the filesystem as a database, so that, e.g., it's easy to
36 ;; manipulate marks from outside Gnus.
37 ;; * All information about a group is stored in the maildir, for easy
38 ;; backup, copying, restoring, etc.
41 ;; * Don't force article renumbering, so nnmaildir can be used with
42 ;; the cache and agent. Alternatively, completely rewrite the Gnus
43 ;; backend interface, which would have other advantages as well.
45 ;; See also <URL:http://multivac.cwru.edu./nnmaildir/> until that
46 ;; information is added to the Gnus manual.
62 (defconst nnmaildir-version "Gnus")
64 (defvar nnmaildir-article-file-name nil
65 "*The filename of the most recently requested article. This variable is set
66 by nnmaildir-request-article.")
68 ;; The filename of the article being moved/copied:
69 (defvar nnmaildir--file nil)
71 ;; Variables to generate filenames of messages being delivered:
72 (defvar nnmaildir--delivery-time "")
73 (defconst nnmaildir--delivery-pid (number-to-string (emacs-pid)))
74 (defvar nnmaildir--delivery-ct nil)
76 ;; An obarry containing symbols whose names are server names and whose values
78 (defvar nnmaildir--servers (make-vector 3 0))
79 ;; The current server:
80 (defvar nnmaildir--cur-server nil)
82 ;; A copy of nnmail-extra-headers
83 (defvar nnmaildir--extra nil)
85 ;; A disk NOV structure (must be prin1-able, so no defstruct) looks like this:
86 ["subject\tfrom\tdate"
87 "references\tchars\lines"
88 "To: you\tIn-Reply-To: <your.mess@ge>"
89 (12345 67890) ;; modtime of the corresponding article file
90 (to in-reply-to)] ;; contemporary value of nnmail-extra-headers
91 (defconst nnmaildir--novlen 5)
92 (defmacro nnmaildir--nov-new (beg mid end mtime extra)
93 `(vector ,beg ,mid ,end ,mtime ,extra))
94 (defmacro nnmaildir--nov-get-beg (nov) `(aref ,nov 0))
95 (defmacro nnmaildir--nov-get-mid (nov) `(aref ,nov 1))
96 (defmacro nnmaildir--nov-get-end (nov) `(aref ,nov 2))
97 (defmacro nnmaildir--nov-get-mtime (nov) `(aref ,nov 3))
98 (defmacro nnmaildir--nov-get-extra (nov) `(aref ,nov 4))
99 (defmacro nnmaildir--nov-set-beg (nov value) `(aset ,nov 0 ,value))
100 (defmacro nnmaildir--nov-set-mid (nov value) `(aset ,nov 1 ,value))
101 (defmacro nnmaildir--nov-set-end (nov value) `(aset ,nov 2 ,value))
102 (defmacro nnmaildir--nov-set-mtime (nov value) `(aset ,nov 3 ,value))
103 (defmacro nnmaildir--nov-set-extra (nov value) `(aset ,nov 4 ,value))
105 (defstruct nnmaildir--art
106 (prefix nil :type string) ;; "time.pid.host"
107 (suffix nil :type string) ;; ":2,flags"
108 (num nil :type natnum) ;; article number
109 (msgid nil :type string) ;; "<mess.age@id>"
110 (nov nil :type vector)) ;; cached nov structure, or nil
112 (defstruct nnmaildir--lists
113 (nlist nil :type list) ;; list of articles, ordered descending by number
114 (flist nil :type vector) ;; obarray mapping filename prefix->article
115 (mlist nil :type vector)) ;; obarray mapping message-id->article
117 (defstruct nnmaildir--grp
118 (name nil :type string) ;; "group.name"
119 (new nil :type list) ;; new/ modtime
120 (cur nil :type list) ;; cur/ modtime
121 (lists nil :type nnmaildir--lists) ;; lists of articles in this group
122 (cache nil :type vector) ;; nov cache
123 (index nil :type natnum) ;; index of next cache entry to replace
124 (mmth nil :type vector)) ;; obarray mapping mark name->dir modtime
126 (defstruct nnmaildir--srv
127 (address nil :type string) ;; server address string
128 (method nil :type list) ;; (nnmaildir "address" ...)
129 (prefix nil :type string) ;; "nnmaildir+address:"
130 (dir nil :type string) ;; "/expanded/path/to/server/dir/"
131 (ls nil :type function) ;; directory-files function
132 (groups nil :type vector) ;; obarray mapping group names->groups
133 (curgrp nil :type nnmaildir--grp) ;; current group, or nil
134 (error nil :type string) ;; last error message, or nil
135 (mtime nil :type list) ;; modtime of dir
136 (gnm nil) ;; flag: split from mail-sources?
137 (create-dir nil :type string)) ;; group creation directory
139 (defmacro nnmaildir--nlist-last-num (nlist)
140 `(let ((nlist ,nlist))
141 (if nlist (nnmaildir--art-num (car nlist)) 0)))
142 (defmacro nnmaildir--nlist-art (nlist num) ;;;; evals args multiple times
144 (>= (nnmaildir--art-num (car ,nlist)) ,num)
145 (nth (- (nnmaildir--art-num (car ,nlist)) ,num) ,nlist)))
146 (defmacro nnmaildir--flist-art (list file)
147 `(symbol-value (intern-soft ,file ,list)))
148 (defmacro nnmaildir--mlist-art (list msgid)
149 `(symbol-value (intern-soft ,msgid ,list)))
151 (defun nnmaildir--pgname (server gname)
152 (let ((prefix (nnmaildir--srv-prefix server)))
153 (if prefix (concat prefix gname)
154 (setq gname (gnus-group-prefixed-name gname
155 (nnmaildir--srv-method server)))
156 (setf (nnmaildir--srv-prefix server) (gnus-group-real-prefix gname))
159 (defun nnmaildir--param (pgname param)
160 (setq param (gnus-group-find-parameter pgname param 'allow-list)
161 param (if (vectorp param) (aref param 0) param))
164 (defmacro nnmaildir--with-nntp-buffer (&rest body)
166 (set-buffer nntp-server-buffer)
168 (defmacro nnmaildir--with-work-buffer (&rest body)
170 (set-buffer (get-buffer-create " *nnmaildir work*"))
172 (defmacro nnmaildir--with-nov-buffer (&rest body)
174 (set-buffer (get-buffer-create " *nnmaildir nov*"))
176 (defmacro nnmaildir--with-move-buffer (&rest body)
178 (set-buffer (get-buffer-create " *nnmaildir move*"))
181 (defmacro nnmaildir--subdir (dir subdir)
182 `(file-name-as-directory (concat ,dir ,subdir)))
183 (defmacro nnmaildir--srvgrp-dir (srv-dir gname)
184 `(nnmaildir--subdir ,srv-dir ,gname))
185 (defmacro nnmaildir--tmp (dir) `(nnmaildir--subdir ,dir "tmp"))
186 (defmacro nnmaildir--new (dir) `(nnmaildir--subdir ,dir "new"))
187 (defmacro nnmaildir--cur (dir) `(nnmaildir--subdir ,dir "cur"))
188 (defmacro nnmaildir--nndir (dir) `(nnmaildir--subdir ,dir ".nnmaildir"))
189 (defmacro nnmaildir--nov-dir (dir) `(nnmaildir--subdir ,dir "nov"))
190 (defmacro nnmaildir--marks-dir (dir) `(nnmaildir--subdir ,dir "marks"))
192 (defmacro nnmaildir--unlink (file-arg)
193 `(let ((file ,file-arg))
194 (if (file-attributes file) (delete-file file))))
195 (defun nnmaildir--mkdir (dir)
196 (or (file-exists-p (file-name-as-directory dir))
197 (make-directory-internal (directory-file-name dir))))
199 (defun nnmaildir--prepare (server group)
203 (or (setq server nnmaildir--cur-server)
205 (or (setq server (intern-soft server nnmaildir--servers))
207 (setq server (symbol-value server)
208 nnmaildir--cur-server server))
209 (or (setq groups (nnmaildir--srv-groups server))
211 (if (nnmaildir--srv-method server) nil
212 (setq x (concat "nnmaildir:" (nnmaildir--srv-address server))
213 x (gnus-server-to-method x))
214 (or x (throw 'return nil))
215 (setf (nnmaildir--srv-method server) x))
217 (or (setq group (nnmaildir--srv-curgrp server))
219 (or (setq group (intern-soft group groups))
221 (setq group (symbol-value group)))
224 (defun nnmaildir--update-nov (server group article)
225 (let ((nnheader-file-coding-system 'binary)
226 (srv-dir (nnmaildir--srv-dir server))
227 dir gname pgname msgdir prefix suffix file attr mtime novdir novfile
228 nov msgid nov-beg nov-mid nov-end field pos extra val old-extra
229 new-extra deactivate-mark)
231 (setq suffix (nnmaildir--art-suffix article))
232 (if (stringp suffix) nil
233 (setf (nnmaildir--art-nov article) nil)
235 (setq gname (nnmaildir--grp-name group)
236 pgname (nnmaildir--pgname server gname)
237 dir (nnmaildir--srvgrp-dir srv-dir gname)
238 msgdir (if (nnmaildir--param pgname 'read-only)
239 (nnmaildir--new dir) (nnmaildir--cur dir))
240 prefix (nnmaildir--art-prefix article)
241 file (concat msgdir prefix suffix)
242 attr (file-attributes file))
244 (setf (nnmaildir--art-suffix article) 'expire)
245 (setf (nnmaildir--art-nov article) nil)
247 (setq mtime (nth 5 attr)
249 nov (nnmaildir--art-nov article)
250 novdir (nnmaildir--nov-dir (nnmaildir--nndir dir))
251 novfile (concat novdir prefix))
252 (or (equal nnmaildir--extra nnmail-extra-headers)
253 (setq nnmaildir--extra (copy-sequence nnmail-extra-headers)))
254 (nnmaildir--with-nov-buffer
255 (when (file-exists-p novfile) ;; If not, force reparsing the message.
256 (if nov nil ;; It's already in memory.
257 ;; Else read the data from the NOV file.
259 (nnheader-insert-file-contents novfile)
260 (setq nov (read (current-buffer)))
261 (setf (nnmaildir--art-msgid article) (car nov))
262 (setq nov (cadr nov)))
263 ;; If the NOV's modtime matches the file's current modtime, and it
264 ;; has the right structure (i.e., it wasn't produced by a too-much
265 ;; older version of nnmaildir), then we may use this NOV data
266 ;; rather than parsing the message file, unless
267 ;; nnmail-extra-headers has been augmented since this data was last
269 (when (and (equal mtime (nnmaildir--nov-get-mtime nov))
270 (= (length nov) nnmaildir--novlen)
271 (stringp (nnmaildir--nov-get-beg nov))
272 (stringp (nnmaildir--nov-get-mid nov))
273 (stringp (nnmaildir--nov-get-end nov))
274 (listp (nnmaildir--nov-get-mtime nov))
275 (listp (nnmaildir--nov-get-extra nov)))
276 ;; this NOV data is potentially up-to-date; now check extra headers
277 (setq old-extra (nnmaildir--nov-get-extra nov))
278 (when (equal nnmaildir--extra old-extra) ;; common case
279 (nnmaildir--nov-set-extra nov nnmaildir--extra) ;; save memory
281 ;; They're not equal, but maybe the new is a subset of the old...
282 (if (null nnmaildir--extra) (throw 'return nov))
283 (setq new-extra nnmaildir--extra)
285 (if (memq (car new-extra) old-extra)
287 (setq new-extra (cdr new-extra))
288 (if new-extra nil (throw 'return nov)))
289 (setq new-extra nil))))) ;;found one not in old-extra;quit loop
290 ;; Parse the NOV data out of the message.
292 (nnheader-insert-file-contents file)
294 (goto-char (point-min))
296 (if (search-forward "\n\n" nil 'noerror)
298 (setq nov-mid (count-lines (point) (point-max)))
299 (narrow-to-region (point-min) (1- (point))))
301 (goto-char (point-min))
303 (nnheader-fold-continuation-lines)
304 (setq nov (nnheader-parse-head 'naked)
305 field (or (mail-header-lines nov) 0)))
306 (if (or (zerop field) (nnmaildir--param pgname 'distrust-Lines:)) nil
307 (setq nov-mid field))
308 (setq nov-mid (number-to-string nov-mid)
309 nov-mid (concat (number-to-string attr) "\t" nov-mid)
310 field (or (mail-header-references nov) "")
313 (while (string-match "\t" field pos)
314 (aset field (match-beginning 0) ? )
315 (setq pos (match-end 0)))
316 (setq nov-mid (concat field "\t" nov-mid)
317 extra (mail-header-extra nov)
320 (setq field (car extra) extra (cdr extra)
321 val (cdr field) field (symbol-name (car field))
323 (while (string-match "\t" field pos)
324 (aset field (match-beginning 0) ? )
325 (setq pos (match-end 0)))
327 (while (string-match "\t" val pos)
328 (aset val (match-beginning 0) ? )
329 (setq pos (match-end 0)))
330 (setq nov-end (concat nov-end "\t" field ": " val)))
331 (setq nov-end (if (zerop (length nov-end)) "" (substring nov-end 1))
332 field (or (mail-header-subject nov) "")
334 (while (string-match "\t" field pos)
335 (aset field (match-beginning 0) ? )
336 (setq pos (match-end 0)))
338 field (or (mail-header-from nov) "")
340 (while (string-match "\t" field pos)
341 (aset field (match-beginning 0) ? )
342 (setq pos (match-end 0)))
343 (setq nov-beg (concat nov-beg "\t" field)
344 field (or (mail-header-date nov) "")
346 (while (string-match "\t" field pos)
347 (aset field (match-beginning 0) ? )
348 (setq pos (match-end 0)))
349 (setq nov-beg (concat nov-beg "\t" field)
350 field (mail-header-id nov)
352 (while (string-match "\t" field pos)
353 (aset field (match-beginning 0) ? )
354 (setq pos (match-end 0)))
356 (if (or (null msgid) (nnheader-fake-message-id-p msgid))
357 (setq msgid (concat "<" prefix "@nnmaildir>")))
358 (setq nov (nnmaildir--nov-new nov-beg nov-mid nov-end mtime
361 (prin1 (list msgid nov) (current-buffer))
362 (setq file (concat novfile ":"))
363 (nnmaildir--unlink file)
364 (write-region (point-min) (point-max) file nil 'no-message))
365 (rename-file file novfile 'replace)
366 (setf (nnmaildir--art-msgid article) msgid)
369 (defun nnmaildir--cache-nov (group article nov)
370 (let ((cache (nnmaildir--grp-cache group))
371 (index (nnmaildir--grp-index group))
373 (if (nnmaildir--art-nov article) nil
374 (setq goner (aref cache index))
375 (if goner (setf (nnmaildir--art-nov goner) nil))
376 (aset cache index article)
377 (setf (nnmaildir--grp-index group) (% (1+ index) (length cache))))
378 (setf (nnmaildir--art-nov article) nov)))
380 (defun nnmaildir--grp-add-art (server group article)
381 (let ((nov (nnmaildir--update-nov server group article))
384 (setq old-lists (nnmaildir--grp-lists group)
385 new-lists (copy-nnmaildir--lists old-lists))
386 (setf (nnmaildir--lists-nlist new-lists)
387 (cons article (nnmaildir--lists-nlist new-lists)))
388 (let ((inhibit-quit t))
389 (setf (nnmaildir--grp-lists group) new-lists)
390 (set (intern (nnmaildir--art-prefix article)
391 (nnmaildir--lists-flist new-lists))
393 (set (intern (nnmaildir--art-msgid article)
394 (nnmaildir--lists-mlist new-lists))
396 (nnmaildir--cache-nov group article nov)
399 (defun nnmaildir--group-ls (server pgname)
400 (or (nnmaildir--param pgname 'directory-files)
401 (nnmaildir--srv-ls server)))
403 (defun nnmaildir--article-count (group)
406 (setq group (nnmaildir--grp-lists group)
407 group (nnmaildir--lists-nlist group))
409 (if (stringp (nnmaildir--art-suffix (car group)))
411 min (nnmaildir--art-num (car group))))
412 (setq group (cdr group)))
415 (defun nnmaildir-article-number-to-file-name
416 (number group-name server-address-string)
417 (let ((group (nnmaildir--prepare server-address-string group-name))
418 list article suffix dir filename pgname)
421 ;; The given group or server does not exist.
423 (setq list (nnmaildir--grp-lists group)
424 list (nnmaildir--lists-nlist list)
425 article (nnmaildir--nlist-art list number))
427 ;; The given article number does not exist in this group.
429 (setq suffix (nnmaildir--art-suffix article))
430 (if (not (stringp suffix))
431 ;; The article has expired.
433 (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
434 dir (nnmaildir--srvgrp-dir dir group-name)
435 pgname (nnmaildir--pgname nnmaildir--cur-server group-name)
436 group (if (nnmaildir--param pgname 'read-only)
437 (nnmaildir--new dir) (nnmaildir--cur dir))
438 filename (concat group (nnmaildir--art-prefix article) suffix))
439 (if (file-exists-p filename)
441 ;; The article disappeared out from under us.
442 (setf (nnmaildir--art-suffix article) 'expire)
443 (setf (nnmaildir--art-nov article) nil)
446 (defun nnmaildir-article-number-to-base-name
447 (number group-name server-address-string)
448 (let ((group (nnmaildir--prepare server-address-string group-name))
449 list article suffix dir filename)
452 ;; The given group or server does not exist.
454 (setq list (nnmaildir--grp-lists group)
455 list (nnmaildir--lists-nlist list)
456 article (nnmaildir--nlist-art list number))
458 ;; The given article number does not exist in this group.
460 (setq suffix (nnmaildir--art-suffix article))
461 (if (not (stringp suffix))
462 ;; The article has expired.
464 (cons (nnmaildir--art-prefix article) suffix))))
466 (defun nnmaildir-base-name-to-article-number
467 (base-name group-name server-address-string)
468 (let ((group (nnmaildir--prepare server-address-string group-name))
469 list article suffix dir filename)
472 ;; The given group or server does not exist.
474 (setq list (nnmaildir--grp-lists group)
475 list (nnmaildir--lists-flist list)
476 article (nnmaildir--flist-art list base-name))
478 ;; The given article number does not exist in this group.
480 (nnmaildir--art-num article))))
482 (defun nnmaildir-request-type (group &optional article)
485 (defun nnmaildir-status-message (&optional server)
486 (nnmaildir--prepare server nil)
487 (nnmaildir--srv-error nnmaildir--cur-server))
489 (defun nnmaildir-server-opened (&optional server)
490 (and nnmaildir--cur-server
492 (string-equal server (nnmaildir--srv-address nnmaildir--cur-server))
494 (nnmaildir--srv-groups nnmaildir--cur-server)
497 (defun nnmaildir-open-server (server &optional defs)
501 (setq server (intern-soft x nnmaildir--servers))
503 (and (setq server (symbol-value server))
504 (nnmaildir--srv-groups server)
505 (setq nnmaildir--cur-server server)
507 (setq server (make-nnmaildir--srv :address x))
508 (let ((inhibit-quit t))
509 (set (intern x nnmaildir--servers) server)))
510 (setq dir (assq 'directory defs))
512 (setf (nnmaildir--srv-error server)
513 "You must set \"directory\" in the select method")
517 dir (expand-file-name dir)
518 dir (file-name-as-directory dir))
519 (if (file-exists-p dir) nil
520 (setf (nnmaildir--srv-error server) (concat "No such directory: " dir))
522 (setf (nnmaildir--srv-dir server) dir)
523 (setq x (assq 'directory-files defs))
525 (setq x (symbol-function (if nnheader-directory-files-is-safe
527 'nnheader-directory-files-safe)))
529 (if (functionp x) nil
530 (setf (nnmaildir--srv-error server)
531 (concat "Not a function: " (prin1-to-string x)))
532 (throw 'return nil)))
533 (setf (nnmaildir--srv-ls server) x)
534 (setq x (funcall x dir nil "\\`[^.]" 'nosort)
537 (while (<= size x) (setq size (* 2 size)))
538 (if (/= size 1) (setq size (1- size)))
539 (and (setq x (assq 'get-new-mail defs))
542 (setf (nnmaildir--srv-gnm server) t)
544 (setq x (assq 'create-directory defs))
548 (setf (nnmaildir--srv-create-dir server) x))
549 (setf (nnmaildir--srv-groups server) (make-vector size 0))
550 (setq nnmaildir--cur-server server)
553 (defun nnmaildir--parse-filename (file)
554 (let ((prefix (car file))
557 "\\`\\([0-9]+\\)\\.\\([0-9]+\\)\\(_\\([0-9]+\\)\\)?\\(\\..*\\)\\'"
560 (setq timestamp (concat "0000" (match-string 1 prefix))
561 len (- (length timestamp) 4))
562 (vector (string-to-number (substring timestamp 0 len))
563 (string-to-number (substring timestamp len))
564 (string-to-number (match-string 2 prefix))
565 (string-to-number (or (match-string 4 prefix) "-1"))
566 (match-string 5 prefix)
570 (defun nnmaildir--sort-files (a b)
573 (throw 'return (and (consp b) (string-lessp (car a) (car b)))))
574 (if (consp b) (throw 'return t))
575 (if (< (aref a 0) (aref b 0)) (throw 'return t))
576 (if (> (aref a 0) (aref b 0)) (throw 'return nil))
577 (if (< (aref a 1) (aref b 1)) (throw 'return t))
578 (if (> (aref a 1) (aref b 1)) (throw 'return nil))
579 (if (< (aref a 2) (aref b 2)) (throw 'return t))
580 (if (> (aref a 2) (aref b 2)) (throw 'return nil))
581 (if (< (aref a 3) (aref b 3)) (throw 'return t))
582 (if (> (aref a 3) (aref b 3)) (throw 'return nil))
583 (string-lessp (aref a 4) (aref b 4))))
585 (defun nnmaildir--scan (gname scan-msgs groups method srv-dir srv-ls)
587 (let ((36h-ago (- (car (current-time)) 2))
588 absdir nndir tdir ndir cdir nattr cattr isnew pgname read-only ls
589 files file num dir flist group x)
590 (setq absdir (nnmaildir--srvgrp-dir srv-dir gname)
591 nndir (nnmaildir--nndir absdir))
592 (if (file-exists-p absdir) nil
593 (setf (nnmaildir--srv-error nnmaildir--cur-server)
594 (concat "No such directory: " absdir))
596 (setq tdir (nnmaildir--tmp absdir)
597 ndir (nnmaildir--new absdir)
598 cdir (nnmaildir--cur absdir)
599 nattr (file-attributes ndir)
600 cattr (file-attributes cdir))
601 (if (and (file-exists-p tdir) nattr cattr) nil
602 (setf (nnmaildir--srv-error nnmaildir--cur-server)
603 (concat "Not a maildir: " absdir))
605 (setq group (nnmaildir--prepare nil gname)
606 pgname (nnmaildir--pgname nnmaildir--cur-server gname))
610 group (make-nnmaildir--grp :name gname :index 0
611 :lists (make-nnmaildir--lists)))
612 (nnmaildir--mkdir nndir)
613 (nnmaildir--mkdir (nnmaildir--nov-dir nndir))
614 (nnmaildir--mkdir (nnmaildir--marks-dir nndir))
615 (write-region "" nil (concat nndir "markfile") nil 'no-message))
616 (setq read-only (nnmaildir--param pgname 'read-only)
617 ls (or (nnmaildir--param pgname 'directory-files) srv-ls))
619 (setq x (nth 11 (file-attributes tdir)))
620 (if (and (= x (nth 11 nattr)) (= x (nth 11 cattr))) nil
621 (setf (nnmaildir--srv-error nnmaildir--cur-server)
622 (concat "Maildir spans filesystems: " absdir))
624 (setq files (funcall ls tdir 'full "\\`[^.]" 'nosort))
626 (setq file (car files) files (cdr files)
627 x (file-attributes file))
628 (if (or (< 1 (cadr x)) (> 36h-ago (car (nth 4 x))))
629 (delete-file file))))
633 (setq nattr (nth 5 nattr))
634 (if (equal nattr (nnmaildir--grp-new group))
636 (if read-only (setq dir (and (or isnew nattr) ndir))
637 (when (or isnew nattr)
638 (setq files (funcall ls ndir nil "\\`[^.]" 'nosort))
640 (setq file (car files) files (cdr files))
641 (rename-file (concat ndir file) (concat cdir file ":2,")))
642 (setf (nnmaildir--grp-new group) nattr))
643 (setq cattr (nth 5 (file-attributes cdir)))
644 (if (equal cattr (nnmaildir--grp-cur group))
646 (setq dir (and (or isnew cattr) cdir)))
647 (if dir nil (throw 'return t))
648 (setq files (funcall ls dir nil "\\`[^.]" 'nosort))
650 (setq x (length files)
652 (while (<= num x) (setq num (* 2 num)))
653 (if (/= num 1) (setq num (1- num)))
654 (setq x (nnmaildir--grp-lists group))
655 (setf (nnmaildir--lists-flist x) (make-vector num 0))
656 (setf (nnmaildir--lists-mlist x) (make-vector num 0))
657 (setf (nnmaildir--grp-mmth group) (make-vector 1 0))
658 (setq num (nnmaildir--param pgname 'nov-cache-size))
659 (if (numberp num) (if (< num 1) (setq num 1))
662 cdir (nnmaildir--marks-dir nndir)
663 ndir (nnmaildir--subdir cdir "tick")
664 cdir (nnmaildir--subdir cdir "read"))
666 (setq file (car x) x (cdr x))
667 (string-match "\\`\\([^:]*\\)\\(\\(:.*\\)?\\)\\'" file)
668 (setq file (match-string 1 file))
669 (if (or (not (file-exists-p (concat cdir file)))
670 (file-exists-p (concat ndir file)))
671 (setq num (1+ num)))))
672 (setf (nnmaildir--grp-cache group) (make-vector num nil))
673 (let ((inhibit-quit t))
674 (set (intern gname groups) group))
675 (or scan-msgs (throw 'return t)))
676 (setq flist (nnmaildir--grp-lists group)
677 num (nnmaildir--lists-nlist flist)
678 flist (nnmaildir--lists-flist flist)
679 num (nnmaildir--nlist-last-num num)
683 (setq file (car x) x (cdr x))
684 (string-match "\\`\\([^:]*\\)\\(\\(:.*\\)?\\)\\'" file)
685 (setq file (cons (match-string 1 file) (match-string 2 file)))
686 (if (nnmaildir--flist-art flist (car file)) nil
687 (setq files (cons file files))))
688 (setq files (mapcar 'nnmaildir--parse-filename files)
689 files (sort files 'nnmaildir--sort-files))
691 (setq file (car files) files (cdr files)
692 file (if (consp file) file (aref file 5))
693 x (make-nnmaildir--art :prefix (car file) :suffix(cdr file)
695 (if (nnmaildir--grp-add-art nnmaildir--cur-server group x)
696 (setq num (1+ num))))
697 (if read-only (setf (nnmaildir--grp-new group) nattr)
698 (setf (nnmaildir--grp-cur group) cattr)))
701 (defun nnmaildir-request-scan (&optional scan-group server)
702 (let ((coding-system-for-write nnheader-file-coding-system)
703 (buffer-file-coding-system nil)
704 (file-coding-system-alist nil)
705 (nnmaildir-new-mail t)
706 (nnmaildir-group-alist nil)
707 (nnmaildir-active-file nil)
708 x srv-ls srv-dir method groups group dirs grp-dir seen deactivate-mark)
709 (nnmaildir--prepare server nil)
710 (setq srv-ls (nnmaildir--srv-ls nnmaildir--cur-server)
711 srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
712 method (nnmaildir--srv-method nnmaildir--cur-server)
713 groups (nnmaildir--srv-groups nnmaildir--cur-server))
714 (nnmaildir--with-work-buffer
716 (if (stringp scan-group)
717 (if (nnmaildir--scan scan-group t groups method srv-dir srv-ls)
718 (if (nnmaildir--srv-gnm nnmaildir--cur-server)
719 (nnmail-get-new-mail 'nnmaildir nil nil scan-group))
720 (unintern scan-group groups))
721 (setq x (nth 5 (file-attributes srv-dir)))
722 (if (equal x (nnmaildir--srv-mtime nnmaildir--cur-server))
724 (mapatoms (lambda (sym)
725 (nnmaildir--scan (symbol-name sym) t groups
726 method srv-dir srv-ls))
728 (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort)
731 (while (<= seen x) (setq seen (* 2 seen)))
732 (if (/= seen 1) (setq seen (1- seen)))
733 (setq seen (make-vector seen 0)
734 scan-group (null scan-group))
736 (setq grp-dir (car dirs) dirs (cdr dirs))
737 (if (nnmaildir--scan grp-dir scan-group groups method srv-dir
739 (intern grp-dir seen)))
741 (mapatoms (lambda (group)
742 (setq group (symbol-name group))
743 (if (intern-soft group seen) nil
744 (setq x (cons group x))))
747 (unintern (car x) groups)
749 (setf (nnmaildir--srv-mtime nnmaildir--cur-server)
750 (nth 5 (file-attributes srv-dir))))
751 (if (nnmaildir--srv-gnm nnmaildir--cur-server)
752 (nnmail-get-new-mail 'nnmaildir nil nil))))))
755 (defun nnmaildir-request-list (&optional server)
756 (nnmaildir-request-scan 'find-new-groups server)
757 (let (pgname ro ct-min deactivate-mark)
758 (nnmaildir--prepare server nil)
759 (nnmaildir--with-nntp-buffer
761 (mapatoms (lambda (group)
762 (setq pgname (symbol-name group)
763 pgname (nnmaildir--pgname nnmaildir--cur-server pgname)
764 group (symbol-value group)
765 ro (nnmaildir--param pgname 'read-only)
766 ct-min (nnmaildir--article-count group))
767 (insert (nnmaildir--grp-name group) " ")
768 (princ (nnmaildir--nlist-last-num
769 (nnmaildir--lists-nlist
770 (nnmaildir--grp-lists group)))
773 (princ (cdr ct-min) nntp-server-buffer)
774 (insert " " (if ro "n" "y") "\n"))
775 (nnmaildir--srv-groups nnmaildir--cur-server))))
778 (defun nnmaildir-request-newgroups (date &optional server)
779 (nnmaildir-request-list server))
781 (defun nnmaildir-retrieve-groups (groups &optional server)
782 (let (gname group ct-min deactivate-mark)
783 (nnmaildir--prepare server nil)
784 (nnmaildir--with-nntp-buffer
787 (setq gname (car groups) groups (cdr groups))
788 (nnmaildir-request-scan gname server)
789 (setq group (nnmaildir--prepare nil gname))
790 (if (null group) (insert "411 no such news group\n")
791 (setq ct-min (nnmaildir--article-count group))
793 (princ (car ct-min) nntp-server-buffer)
795 (princ (cdr ct-min) nntp-server-buffer)
797 (princ (nnmaildir--nlist-last-num
798 (nnmaildir--lists-nlist
799 (nnmaildir--grp-lists group)))
801 (insert " " gname "\n")))))
804 (defun nnmaildir-request-update-info (gname info &optional server)
805 (nnmaildir-request-scan gname server)
806 (let ((group (nnmaildir--prepare server gname))
807 pgname nlist flist last always-marks never-marks old-marks dotfile num
808 dir markdirs marks mark ranges articles article read end new-marks ls
809 old-mmth new-mmth mtime mark-sym deactivate-mark)
812 (setf (nnmaildir--srv-error nnmaildir--cur-server)
813 (concat "No such group: " gname))
815 (setq gname (nnmaildir--grp-name group)
816 pgname (nnmaildir--pgname nnmaildir--cur-server gname)
817 nlist (nnmaildir--grp-lists group)
818 flist (nnmaildir--lists-flist nlist)
819 nlist (nnmaildir--lists-nlist nlist))
821 (gnus-info-set-read info nil)
822 (gnus-info-set-marks info nil 'extend)
823 (throw 'return info))
824 (setq old-marks (cons 'read (gnus-info-read info))
825 old-marks (cons old-marks (gnus-info-marks info))
826 last (nnmaildir--nlist-last-num nlist)
827 always-marks (nnmaildir--param pgname 'always-marks)
828 never-marks (nnmaildir--param pgname 'never-marks)
829 dir (nnmaildir--srv-dir nnmaildir--cur-server)
830 dir (nnmaildir--srvgrp-dir dir gname)
831 dir (nnmaildir--nndir dir)
832 dir (nnmaildir--marks-dir dir)
833 ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
834 markdirs (funcall ls dir nil "\\`[^.]" 'nosort)
835 num (length markdirs)
837 (while (<= new-mmth num) (setq new-mmth (* 2 new-mmth)))
838 (if (/= new-mmth 1) (setq new-mmth (1- new-mmth)))
839 (setq new-mmth (make-vector new-mmth 0)
840 old-mmth (nnmaildir--grp-mmth group))
842 (setq mark (car markdirs) markdirs (cdr markdirs)
843 articles (nnmaildir--subdir dir mark)
844 mark-sym (intern mark)
847 (if (memq mark-sym never-marks) (throw 'got-ranges nil))
848 (when (memq mark-sym always-marks)
849 (setq ranges (list (cons 1 last)))
850 (throw 'got-ranges nil))
851 (setq mtime (nth 5 (file-attributes articles)))
852 (set (intern mark new-mmth) mtime)
853 (when (equal mtime (symbol-value (intern-soft mark old-mmth)))
854 (setq ranges (assq mark-sym old-marks))
855 (if ranges (setq ranges (cdr ranges)))
856 (throw 'got-ranges nil))
857 (setq articles (funcall ls articles nil "\\`[^.]" 'nosort))
859 (setq article (car articles) articles (cdr articles)
860 article (nnmaildir--flist-art flist article))
862 (setq num (nnmaildir--art-num article)
863 ranges (gnus-add-to-range ranges (list num))))))
864 (if (eq mark-sym 'read) (setq read ranges)
865 (if ranges (setq marks (cons (cons mark-sym ranges) marks)))))
866 (gnus-info-set-read info read)
867 (gnus-info-set-marks info marks 'extend)
868 (setf (nnmaildir--grp-mmth group) new-mmth)
871 (defun nnmaildir-request-group (gname &optional server fast)
872 (nnmaildir-request-scan gname server)
873 (let ((group (nnmaildir--prepare server gname))
874 ct-min deactivate-mark)
875 (nnmaildir--with-nntp-buffer
879 (insert "411 no such news group\n")
880 (setf (nnmaildir--srv-error nnmaildir--cur-server)
881 (concat "No such group: " gname))
883 (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) group)
884 (if fast (throw 'return t))
885 (setq ct-min (nnmaildir--article-count group))
887 (princ (car ct-min) nntp-server-buffer)
889 (princ (cdr ct-min) nntp-server-buffer)
891 (princ (nnmaildir--nlist-last-num
892 (nnmaildir--lists-nlist
893 (nnmaildir--grp-lists group)))
895 (insert " " gname "\n")
898 (defun nnmaildir-request-create-group (gname &optional server args)
899 (nnmaildir--prepare server nil)
901 (let ((create-dir (nnmaildir--srv-create-dir nnmaildir--cur-server))
903 (when (zerop (length gname))
904 (setf (nnmaildir--srv-error nnmaildir--cur-server)
905 "Invalid (empty) group name")
907 (when (eq (aref "." 0) (aref gname 0))
908 (setf (nnmaildir--srv-error nnmaildir--cur-server)
909 "Group names may not start with \".\"")
911 (when (save-match-data (string-match "[\0/\t]" gname))
912 (setf (nnmaildir--srv-error nnmaildir--cur-server)
913 (concat "Illegal characters (null, tab, or /) in group name: "
916 (setq groups (nnmaildir--srv-groups nnmaildir--cur-server))
917 (when (intern-soft gname groups)
918 (setf (nnmaildir--srv-error nnmaildir--cur-server)
919 (concat "Group already exists: " gname))
921 (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server))
922 (if (file-name-absolute-p create-dir)
923 (setq dir (expand-file-name create-dir))
925 dir (file-truename dir)
926 dir (concat dir create-dir)))
927 (setq dir (nnmaildir--subdir (file-name-as-directory dir) gname))
928 (nnmaildir--mkdir dir)
929 (nnmaildir--mkdir (nnmaildir--tmp dir))
930 (nnmaildir--mkdir (nnmaildir--new dir))
931 (nnmaildir--mkdir (nnmaildir--cur dir))
932 (setq create-dir (file-name-as-directory create-dir))
933 (make-symbolic-link (concat create-dir gname) (concat srv-dir gname))
934 (nnmaildir-request-scan 'find-new-groups))))
936 (defun nnmaildir-request-rename-group (gname new-name &optional server)
937 (let ((group (nnmaildir--prepare server gname))
938 (coding-system-for-write nnheader-file-coding-system)
939 (buffer-file-coding-system nil)
940 (file-coding-system-alist nil)
944 (setf (nnmaildir--srv-error nnmaildir--cur-server)
945 (concat "No such group: " gname))
947 (when (zerop (length new-name))
948 (setf (nnmaildir--srv-error nnmaildir--cur-server)
949 "Invalid (empty) group name")
951 (when (eq (aref "." 0) (aref new-name 0))
952 (setf (nnmaildir--srv-error nnmaildir--cur-server)
953 "Group names may not start with \".\"")
955 (when (save-match-data (string-match "[\0/\t]" new-name))
956 (setf (nnmaildir--srv-error nnmaildir--cur-server)
957 (concat "Illegal characters (null, tab, or /) in group name: "
960 (if (string-equal gname new-name) (throw 'return t))
961 (when (intern-soft new-name
962 (nnmaildir--srv-groups nnmaildir--cur-server))
963 (setf (nnmaildir--srv-error nnmaildir--cur-server)
964 (concat "Group already exists: " new-name))
966 (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server))
968 (rename-file (concat srv-dir gname)
969 (concat srv-dir new-name))
971 (setf (nnmaildir--srv-error nnmaildir--cur-server)
972 (concat "Error renaming link: " (prin1-to-string err)))
973 (throw 'return nil)))
974 (setq x (nnmaildir--srv-groups nnmaildir--cur-server)
975 groups (make-vector (length x) 0))
976 (mapatoms (lambda (sym)
977 (if (eq (symbol-value sym) group) nil
978 (set (intern (symbol-name sym) groups)
979 (symbol-value sym))))
981 (setq group (copy-sequence group))
982 (setf (nnmaildir--grp-name group) new-name)
983 (set (intern new-name groups) group)
984 (setf (nnmaildir--srv-groups nnmaildir--cur-server) groups)
987 (defun nnmaildir-request-delete-group (gname force &optional server)
988 (let ((group (nnmaildir--prepare server gname))
989 pgname grp-dir dir dirs files ls deactivate-mark)
992 (setf (nnmaildir--srv-error nnmaildir--cur-server)
993 (concat "No such group: " gname))
995 (if (eq group (nnmaildir--srv-curgrp nnmaildir--cur-server))
996 (setf (nnmaildir--srv-curgrp nnmaildir--cur-server) nil))
997 (setq gname (nnmaildir--grp-name group)
998 pgname (nnmaildir--pgname nnmaildir--cur-server gname))
999 (unintern gname (nnmaildir--srv-groups nnmaildir--cur-server))
1000 (setq grp-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1001 grp-dir (nnmaildir--srvgrp-dir grp-dir gname))
1002 (if (not force) (setq grp-dir (directory-file-name grp-dir))
1003 (if (nnmaildir--param pgname 'read-only)
1004 (progn (delete-directory (nnmaildir--tmp grp-dir))
1005 (nnmaildir--unlink (nnmaildir--new grp-dir))
1006 (delete-directory (nnmaildir--cur grp-dir)))
1007 (nnmaildir--with-work-buffer
1009 (setq ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1010 files (funcall ls (nnmaildir--tmp grp-dir) 'full "\\`[^.]"
1013 (delete-file (car files))
1014 (setq files (cdr files)))
1015 (delete-directory (nnmaildir--tmp grp-dir))
1016 (setq files (funcall ls (nnmaildir--new grp-dir) 'full "\\`[^.]"
1019 (delete-file (car files))
1020 (setq files (cdr files)))
1021 (delete-directory (nnmaildir--new grp-dir))
1022 (setq files (funcall ls (nnmaildir--cur grp-dir) 'full "\\`[^.]"
1025 (delete-file (car files))
1026 (setq files (cdr files)))
1027 (delete-directory (nnmaildir--cur grp-dir))))
1028 (setq dir (nnmaildir--nndir grp-dir)
1029 dirs (cons (nnmaildir--nov-dir dir)
1030 (funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]"
1033 (setq dir (car dirs) dirs (cdr dirs)
1034 files (funcall ls dir 'full "\\`[^.]" 'nosort))
1036 (delete-file (car files))
1037 (setq files (cdr files)))
1038 (delete-directory dir))
1039 (setq dir (nnmaildir--nndir grp-dir))
1040 (nnmaildir--unlink (concat dir "markfile"))
1041 (nnmaildir--unlink (concat dir "markfile{new}"))
1042 (delete-directory (nnmaildir--marks-dir dir))
1043 (delete-directory dir)
1044 (setq grp-dir (directory-file-name grp-dir)
1045 dir (car (file-attributes grp-dir)))
1046 (if (eq (aref "/" 0) (aref dir 0)) nil
1047 (setq dir (concat (file-truename
1048 (nnmaildir--srv-dir nnmaildir--cur-server))
1050 (delete-directory dir))
1051 (nnmaildir--unlink grp-dir)
1054 (defun nnmaildir-retrieve-headers (articles &optional gname server fetch-old)
1055 (let ((group (nnmaildir--prepare server gname))
1056 srv-dir dir nlist mlist article num stop nov nlist2 deactivate-mark)
1059 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1060 (if gname (concat "No such group: " gname) "No current group"))
1061 (throw 'return nil))
1062 (nnmaildir--with-nntp-buffer
1064 (setq nlist (nnmaildir--grp-lists group)
1065 mlist (nnmaildir--lists-mlist nlist)
1066 nlist (nnmaildir--lists-nlist nlist)
1067 gname (nnmaildir--grp-name group)
1068 srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1069 dir (nnmaildir--srvgrp-dir srv-dir gname))
1072 ((and fetch-old (not (numberp fetch-old)))
1074 (setq article (car nlist) nlist (cdr nlist)
1075 nov (nnmaildir--update-nov nnmaildir--cur-server group
1078 (nnmaildir--cache-nov group article nov)
1079 (setq num (nnmaildir--art-num article))
1080 (princ num nntp-server-buffer)
1081 (insert "\t" (nnmaildir--nov-get-beg nov) "\t"
1082 (nnmaildir--art-msgid article) "\t"
1083 (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir " gname
1085 (princ num nntp-server-buffer)
1086 (insert "\t" (nnmaildir--nov-get-end nov) "\n")
1087 (goto-char (point-min)))))
1089 ((stringp (car articles))
1091 (setq article (car articles) articles (cdr articles)
1092 article (nnmaildir--mlist-art mlist article))
1094 (setq nov (nnmaildir--update-nov nnmaildir--cur-server
1096 (nnmaildir--cache-nov group article nov)
1097 (setq num (nnmaildir--art-num article))
1098 (princ num nntp-server-buffer)
1099 (insert "\t" (nnmaildir--nov-get-beg nov) "\t"
1100 (nnmaildir--art-msgid article) "\t"
1101 (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir " gname
1103 (princ num nntp-server-buffer)
1104 (insert "\t" (nnmaildir--nov-get-end nov) "\n"))))
1107 ;; Assume the article range is sorted ascending
1108 (setq stop (car articles)
1109 num (car (last articles))
1110 stop (if (numberp stop) stop (car stop))
1111 num (if (numberp num) num (cdr num))
1112 stop (- stop fetch-old)
1113 stop (if (< stop 1) 1 stop)
1114 articles (list (cons stop num))))
1116 (setq stop (car articles) articles (cdr articles))
1117 (while (eq stop (car articles))
1118 (setq articles (cdr articles)))
1119 (if (numberp stop) (setq num stop)
1120 (setq num (cdr stop) stop (car stop)))
1121 (setq nlist2 (nthcdr (- (nnmaildir--art-num (car nlist)) num)
1124 (setq article (car nlist2)
1125 num (nnmaildir--art-num article))
1127 (setq nlist2 (cdr nlist2)
1128 nov (nnmaildir--update-nov nnmaildir--cur-server group
1131 (nnmaildir--cache-nov group article nov)
1132 (princ num nntp-server-buffer)
1133 (insert "\t" (nnmaildir--nov-get-beg nov) "\t"
1134 (nnmaildir--art-msgid article) "\t"
1135 (nnmaildir--nov-get-mid nov) "\tXref: nnmaildir " gname
1137 (princ num nntp-server-buffer)
1138 (insert "\t" (nnmaildir--nov-get-end nov) "\n")
1139 (goto-char (point-min)))))))
1140 (sort-numeric-fields 1 (point-min) (point-max))
1143 (defun nnmaildir-request-article (num-msgid &optional gname server to-buffer)
1144 (let ((group (nnmaildir--prepare server gname))
1145 (case-fold-search t)
1146 list article suffix dir pgname deactivate-mark)
1149 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1150 (if gname (concat "No such group: " gname) "No current group"))
1151 (throw 'return nil))
1152 (setq list (nnmaildir--grp-lists group))
1153 (if (numberp num-msgid)
1154 (setq list (nnmaildir--lists-nlist list)
1155 article (nnmaildir--nlist-art list num-msgid))
1156 (setq list (nnmaildir--lists-mlist list)
1157 article (nnmaildir--mlist-art list num-msgid))
1158 (if article (setq num-msgid (nnmaildir--art-num article))
1162 (setq group (symbol-value grp)
1163 list (nnmaildir--grp-lists group)
1164 list (nnmaildir--lists-mlist list)
1165 article (nnmaildir--mlist-art list num-msgid))
1167 (setq num-msgid (nnmaildir--art-num article))
1168 (throw 'found nil)))
1169 (nnmaildir--srv-groups nnmaildir--cur-server)))))
1171 (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
1172 (throw 'return nil))
1173 (if (stringp (setq suffix (nnmaildir--art-suffix article))) nil
1174 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1175 "Article has expired")
1176 (throw 'return nil))
1177 (setq gname (nnmaildir--grp-name group)
1178 pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1179 dir (nnmaildir--srv-dir nnmaildir--cur-server)
1180 dir (nnmaildir--srvgrp-dir dir gname)
1181 group (if (nnmaildir--param pgname 'read-only)
1182 (nnmaildir--new dir) (nnmaildir--cur dir))
1183 nnmaildir-article-file-name (concat group
1184 (nnmaildir--art-prefix
1187 (if (file-exists-p nnmaildir-article-file-name) nil
1188 (setf (nnmaildir--art-suffix article) 'expire)
1189 (setf (nnmaildir--art-nov article) nil)
1190 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1191 "Article has expired")
1192 (throw 'return nil))
1194 (set-buffer (or to-buffer nntp-server-buffer))
1196 (nnheader-insert-file-contents nnmaildir-article-file-name))
1197 (cons gname num-msgid))))
1199 (defun nnmaildir-request-post (&optional server)
1200 (let (message-required-mail-headers)
1201 (funcall message-send-mail-function)))
1203 (defun nnmaildir-request-replace-article (article gname buffer)
1204 (let ((group (nnmaildir--prepare nil gname))
1205 (coding-system-for-write nnheader-file-coding-system)
1206 (buffer-file-coding-system nil)
1207 (file-coding-system-alist nil)
1208 file dir suffix tmpfile deactivate-mark)
1211 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1212 (concat "No such group: " gname))
1213 (throw 'return nil))
1214 (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
1216 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1217 (concat "Read-only group: " group))
1218 (throw 'return nil))
1219 (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
1220 dir (nnmaildir--srvgrp-dir dir gname)
1221 file (nnmaildir--grp-lists group)
1222 file (nnmaildir--lists-nlist file)
1223 file (nnmaildir--nlist-art file article))
1224 (if (and file (stringp (setq suffix (nnmaildir--art-suffix file))))
1226 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1227 (format "No such article: %d" article))
1228 (throw 'return nil))
1232 file (nnmaildir--art-prefix article)
1233 tmpfile (concat (nnmaildir--tmp dir) file))
1234 (when (file-exists-p tmpfile)
1235 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1236 (concat "File exists: " tmpfile))
1237 (throw 'return nil))
1238 (write-region (point-min) (point-max) tmpfile nil 'no-message nil
1239 'confirm-overwrite)) ;; error would be preferred :(
1240 (unix-sync) ;; no fsync :(
1241 (rename-file tmpfile (concat (nnmaildir--cur dir) file suffix) 'replace)
1244 (defun nnmaildir-request-move-article (article gname server accept-form
1246 (let ((group (nnmaildir--prepare server gname))
1247 pgname list suffix result nnmaildir--file deactivate-mark)
1250 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1251 (concat "No such group: " gname))
1252 (throw 'return nil))
1253 (setq gname (nnmaildir--grp-name group)
1254 pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1255 list (nnmaildir--grp-lists group)
1256 list (nnmaildir--lists-nlist list)
1257 article (nnmaildir--nlist-art list article))
1259 (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
1260 (throw 'return nil))
1261 (if (stringp (setq suffix (nnmaildir--art-suffix article))) nil
1262 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1263 "Article has expired")
1264 (throw 'return nil))
1265 (setq nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
1266 nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname)
1267 nnmaildir--file (if (nnmaildir--param pgname 'read-only)
1268 (nnmaildir--new nnmaildir--file)
1269 (nnmaildir--cur nnmaildir--file))
1270 nnmaildir--file (concat nnmaildir--file
1271 (nnmaildir--art-prefix article)
1273 (if (file-exists-p nnmaildir--file) nil
1274 (setf (nnmaildir--art-suffix article) 'expire)
1275 (setf (nnmaildir--art-nov article) nil)
1276 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1277 "Article has expired")
1278 (throw 'return nil))
1279 (nnmaildir--with-move-buffer
1281 (nnheader-insert-file-contents nnmaildir--file)
1282 (setq result (eval accept-form)))
1283 (if (or (null result) (nnmaildir--param pgname 'read-only)) nil
1284 (nnmaildir--unlink nnmaildir--file)
1285 (setf (nnmaildir--art-suffix article) 'expire)
1286 (setf (nnmaildir--art-nov article) nil))
1289 (defun nnmaildir-request-accept-article (gname &optional server last)
1290 (let ((group (nnmaildir--prepare server gname))
1291 (coding-system-for-write nnheader-file-coding-system)
1292 (buffer-file-coding-system nil)
1293 (file-coding-system-alist nil)
1294 srv-dir dir file tmpfile curfile 24h num article)
1297 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1298 (concat "No such group: " gname))
1299 (throw 'return nil))
1300 (setq gname (nnmaildir--grp-name group))
1301 (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
1303 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1304 (concat "Read-only group: " gname))
1305 (throw 'return nil))
1306 (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1307 dir (nnmaildir--srvgrp-dir srv-dir gname)
1308 file (format-time-string "%s" nil))
1309 (if (string-equal nnmaildir--delivery-time file) nil
1310 (setq nnmaildir--delivery-time file
1311 nnmaildir--delivery-ct 0))
1312 (setq file (concat file "." nnmaildir--delivery-pid))
1313 (if (zerop nnmaildir--delivery-ct) nil
1314 (setq file (concat file "_"
1315 (number-to-string nnmaildir--delivery-ct))))
1316 (setq file (concat file "." (system-name))
1317 tmpfile (concat (nnmaildir--tmp dir) file)
1318 curfile (concat (nnmaildir--cur dir) file ":2,"))
1319 (when (file-exists-p tmpfile)
1320 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1321 (concat "File exists: " tmpfile))
1322 (throw 'return nil))
1323 (when (file-exists-p curfile)
1324 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1325 (concat "File exists: " curfile))
1326 (throw 'return nil))
1327 (setq nnmaildir--delivery-ct (1+ nnmaildir--delivery-ct)
1328 24h (run-with-timer 86400 nil
1330 (nnmaildir--unlink tmpfile)
1331 (setf (nnmaildir--srv-error
1332 nnmaildir--cur-server)
1333 "24-hour timer expired")
1334 (throw 'return nil))))
1336 (add-name-to-file nnmaildir--file tmpfile)
1338 (write-region (point-min) (point-max) tmpfile nil 'no-message nil
1339 'confirm-overwrite) ;; error would be preferred :(
1340 (unix-sync))) ;; no fsync :(
1343 (add-name-to-file tmpfile curfile)
1345 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1346 (concat "Error linking: " (prin1-to-string err)))
1347 (nnmaildir--unlink tmpfile)
1348 (throw 'return nil)))
1349 (nnmaildir--unlink tmpfile)
1350 (setq num (nnmaildir--grp-lists group)
1351 num (nnmaildir--lists-nlist num)
1352 num (1+ (nnmaildir--nlist-last-num num))
1353 article (make-nnmaildir--art :prefix file :suffix ":2," :num num))
1354 (if (nnmaildir--grp-add-art nnmaildir--cur-server group article)
1355 (cons gname num)))))
1357 (defun nnmaildir-save-mail (group-art)
1360 (throw 'return nil))
1361 (let ((ret group-art)
1362 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 (if (nnmaildir-request-accept-article gname) nil
1376 (throw 'return nil))
1377 (setq x (nnmaildir--prepare nil gname)
1378 nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
1379 nnmaildir--file (nnmaildir--subdir nnmaildir--file
1380 (nnmaildir--grp-name x))
1381 x (nnmaildir--grp-lists x)
1382 x (nnmaildir--lists-nlist x)
1384 nnmaildir--file (concat nnmaildir--file
1385 (nnmaildir--art-prefix x)
1386 (nnmaildir--art-suffix x)))
1388 (setq ga (car group-art) group-art (cdr group-art)
1390 (if (and (or (intern-soft gname groups)
1391 (nnmaildir-request-create-group gname))
1392 (nnmaildir-request-accept-article gname)) nil
1393 (setq ret (delq ga ret)))) ;; We'll still try the other groups
1396 (defun nnmaildir-active-number (group)
1397 (let ((x (nnmaildir--prepare nil group)))
1400 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1401 (concat "No such group: " group))
1402 (throw 'return nil))
1403 (setq x (nnmaildir--grp-lists x)
1404 x (nnmaildir--lists-nlist x))
1407 x (nnmaildir--art-num x)
1411 (defun nnmaildir-request-expire-articles (ranges &optional gname server force)
1412 (let ((no-force (not force))
1413 (group (nnmaildir--prepare server gname))
1414 pgname time boundary time-iter bound-iter high low target dir nlist
1415 stop number article didnt suffix nnmaildir--file
1416 nnmaildir-article-file-name deactivate-mark)
1419 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1420 (if gname (concat "No such group: " gname) "No current group"))
1421 (throw 'return (gnus-uncompress-range ranges)))
1422 (setq gname (nnmaildir--grp-name group)
1423 pgname (nnmaildir--pgname nnmaildir--cur-server gname))
1424 (if (nnmaildir--param pgname 'read-only)
1425 (throw 'return (gnus-uncompress-range ranges)))
1426 (setq time (or (nnmaildir--param pgname 'expire-age)
1427 (* 86400 ;; seconds per day
1428 (or (and nnmail-expiry-wait-function
1429 (funcall nnmail-expiry-wait-function gname))
1430 nnmail-expiry-wait))))
1431 (if (or force (integerp time)) nil
1432 (throw 'return (gnus-uncompress-range ranges)))
1433 (setq boundary (current-time)
1434 high (- (car boundary) (/ time 65536))
1435 low (- (cadr boundary) (% time 65536)))
1437 (setq low (+ low 65536)
1439 (setcar (cdr boundary) low)
1440 (setcar boundary high)
1441 (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
1442 dir (nnmaildir--srvgrp-dir dir gname)
1443 dir (nnmaildir--cur dir)
1444 nlist (nnmaildir--grp-lists group)
1445 nlist (nnmaildir--lists-nlist nlist)
1446 ranges (reverse ranges))
1447 (nnmaildir--with-move-buffer
1449 (setq number (car ranges) ranges (cdr ranges))
1450 (while (eq number (car ranges))
1451 (setq ranges (cdr ranges)))
1452 (if (numberp number) (setq stop number)
1453 (setq stop (car number) number (cdr number)))
1454 (setq nlist (nthcdr (- (nnmaildir--art-num (car nlist)) number)
1457 (setq article (car nlist)
1458 number (nnmaildir--art-num article))
1460 (setq nlist (cdr nlist)
1461 suffix (nnmaildir--art-suffix article))
1463 (if (stringp suffix) nil
1464 (setf (nnmaildir--art-suffix article) 'expire)
1465 (setf (nnmaildir--art-nov article) nil)
1466 (throw 'continue nil))
1467 (setq nnmaildir--file (nnmaildir--art-prefix article)
1468 nnmaildir--file (concat dir nnmaildir--file suffix)
1469 time (file-attributes nnmaildir--file))
1471 (setf (nnmaildir--art-suffix article) 'expire)
1472 (setf (nnmaildir--art-nov article) nil)
1473 (throw 'continue nil))
1474 (setq time (nth 5 time)
1476 bound-iter boundary)
1479 (while (and bound-iter time-iter
1480 (= (car bound-iter) (car time-iter)))
1481 (setq bound-iter (cdr bound-iter)
1482 time-iter (cdr time-iter)))
1483 (and bound-iter time-iter
1484 (car-less-than-car bound-iter time-iter))))
1485 (setq didnt (cons number didnt))
1487 (setq nnmaildir-article-file-name nnmaildir--file
1488 target (nnmaildir--param pgname 'expire-group)))
1489 (when (and (stringp target)
1490 (not (string-equal target pgname))) ;; Move it.
1492 (nnheader-insert-file-contents nnmaildir--file)
1493 (gnus-request-accept-article target nil nil 'no-encode))
1494 (if (equal target pgname)
1495 (setq didnt (cons number didnt)) ;; Leave it here.
1496 (nnmaildir--unlink nnmaildir--file)
1497 (setf (nnmaildir--art-suffix article) 'expire)
1498 (setf (nnmaildir--art-nov article) nil))))))
1502 (defun nnmaildir-request-set-mark (gname actions &optional server)
1503 (let ((group (nnmaildir--prepare server gname))
1504 (coding-system-for-write nnheader-file-coding-system)
1505 (buffer-file-coding-system nil)
1506 (file-coding-system-alist nil)
1507 del-mark add-marks marksdir markfile action group-nlist nlist ranges
1508 begin end article all-marks todo-marks did-marks marks form mdir mfile
1509 pgname ls markfilenew deactivate-mark)
1512 (setq mfile (nnmaildir--subdir marksdir (symbol-name (car marks)))
1513 mfile (concat mfile (nnmaildir--art-prefix article)))
1514 (nnmaildir--unlink mfile))
1518 (setq mdir (nnmaildir--subdir marksdir (symbol-name (car marks)))
1519 mfile (concat mdir (nnmaildir--art-prefix article)))
1520 (if (memq (car marks) did-marks) nil
1521 (nnmaildir--mkdir mdir)
1522 (setq did-marks (cons (car marks) did-marks)))
1523 (if (file-exists-p mfile) nil
1525 (add-name-to-file markfile mfile)
1527 (if (file-exists-p mfile) nil
1528 ;; too many links, maybe
1529 (write-region "" nil markfilenew nil 'no-message)
1530 (add-name-to-file markfilenew mfile 'ok-if-already-exists)
1531 (rename-file markfilenew markfile 'replace)))))
1532 (setq marks (cdr marks)))))
1535 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1536 (concat "No such group: " gname))
1538 (setq ranges (gnus-range-add ranges (caar actions))
1539 actions (cdr actions)))
1540 (throw 'return ranges))
1541 (setq group-nlist (nnmaildir--grp-lists group)
1542 group-nlist (nnmaildir--lists-nlist group-nlist)
1543 marksdir (nnmaildir--srv-dir nnmaildir--cur-server)
1544 marksdir (nnmaildir--srvgrp-dir marksdir gname)
1545 marksdir (nnmaildir--nndir marksdir)
1546 markfile (concat marksdir "markfile")
1547 markfilenew (concat markfile "{new}")
1548 marksdir (nnmaildir--marks-dir marksdir)
1549 gname (nnmaildir--grp-name group)
1550 pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1551 ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1552 all-marks (funcall ls marksdir nil "\\`[^.]" 'nosort)
1555 (setcar marks (intern (car marks)))
1556 (setq marks (cdr marks)))
1558 (setq action (car actions) actions (cdr actions)
1561 todo-marks (caddr action)
1564 (if (memq (car marks) all-marks) nil
1565 (setq all-marks (cons (car marks) all-marks)))
1566 (setq marks (cdr marks)))
1569 ((eq 'del (cadr action))
1572 (setq marks (cdr marks))))
1573 ((eq 'add (cadr action)) '(funcall add-marks))
1577 (setq marks all-marks)
1579 (if (memq (car marks) todo-marks) nil
1581 (setq marks (cdr marks)))))))
1582 (if (numberp (cdr ranges)) (setq ranges (list ranges))
1583 (setq ranges (reverse ranges)))
1585 (setq begin (car ranges) ranges (cdr ranges))
1586 (while (eq begin (car ranges))
1587 (setq ranges (cdr ranges)))
1588 (if (numberp begin) (setq end begin)
1589 (setq end (cdr begin) begin (car begin)))
1590 (setq nlist (nthcdr (- (nnmaildir--art-num (car nlist)) end)
1593 (setq article (car nlist))
1594 (>= (nnmaildir--art-num article) begin))
1595 (setq nlist (cdr nlist))
1596 (when (stringp (nnmaildir--art-suffix article))
1597 (setq marks todo-marks)
1601 (defun nnmaildir-close-group (group &optional server)
1604 (defun nnmaildir-close-server (&optional server)
1605 (let (flist ls dirs dir files file x)
1606 (nnmaildir--prepare server nil)
1607 (setq server nnmaildir--cur-server)
1609 (setq nnmaildir--cur-server nil)
1613 (setq x (nnmaildir--pgname server (symbol-name group))
1614 group (symbol-value group)
1615 ls (nnmaildir--group-ls server x)
1616 dir (nnmaildir--srv-dir server)
1617 dir (nnmaildir--srvgrp-dir dir (nnmaildir--grp-name group))
1618 x (nnmaildir--param x 'read-only)
1619 x (if x (nnmaildir--new dir) (nnmaildir--cur dir))
1620 files (funcall ls x nil "\\`[^.]" 'nosort)
1623 (while (<= flist x) (setq flist (* 2 flist)))
1624 (if (/= flist 1) (setq flist (1- flist)))
1625 (setq flist (make-vector flist 0))
1627 (setq file (car files) files (cdr files))
1628 (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file)
1629 (intern (match-string 1 file) flist))
1630 (setq dir (nnmaildir--nndir dir)
1631 dirs (cons (nnmaildir--nov-dir dir)
1632 (funcall ls (nnmaildir--marks-dir dir) 'full
1633 "\\`[^.]" 'nosort)))
1635 (setq dir (car dirs) dirs (cdr dirs)
1636 files (funcall ls dir nil "\\`[^.]" 'nosort)
1637 dir (file-name-as-directory dir))
1639 (setq file (car files) files (cdr files))
1640 (if (intern-soft file flist) nil
1641 (setq file (concat dir file))
1642 (delete-file file)))))
1643 (nnmaildir--srv-groups server)))
1644 (unintern (nnmaildir--srv-address server) nnmaildir--servers)))
1647 (defun nnmaildir-request-close ()
1648 (let (servers buffer)
1649 (mapatoms (lambda (server)
1650 (setq servers (cons (symbol-name server) servers)))
1653 (nnmaildir-close-server (car servers))
1654 (setq servers (cdr servers)))
1655 (setq buffer (get-buffer " *nnmaildir work*"))
1656 (if buffer (kill-buffer buffer))
1657 (setq buffer (get-buffer " *nnmaildir nov*"))
1658 (if buffer (kill-buffer buffer))
1659 (setq buffer (get-buffer " *nnmaildir move*"))
1660 (if buffer (kill-buffer buffer)))
1663 (defun nnmaildir--edit-prep ()
1664 (let ((extras '(mapcar mapatoms))
1668 (when (or (memq sym extras)
1670 (setq name (symbol-name sym))
1671 (>= (length name) 10)
1672 (or (string-equal "nnmaildir-" (substring name 0 10))
1673 (and (>= (length name) 15)
1674 (string-equal "make-nnmaildir-"
1675 (substring name 0 15))))))
1676 (put sym 'lisp-indent-function 0))))
1679 (provide 'nnmaildir)
1682 ;; indent-tabs-mode: t
1684 ;; eval: (progn (require 'nnmaildir) (nnmaildir--edit-prep))
1687 ;;; nnmaildir.el ends here