1 ;;; nnmaildir.el --- maildir backend for Gnus
3 ;; This file is in the public domain.
5 ;; Author: Paul Jarc <prj@po.cwru.edu>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 ;; Maildir format is documented at <URL:http://cr.yp.to/proto/maildir.html>
25 ;; and in the maildir(5) man page from qmail (available at
26 ;; <URL:http://www.qmail.org/man/man5/maildir.html>). nnmaildir also stores
27 ;; extra information in the .nnmaildir/ directory within a maildir.
29 ;; Some goals of nnmaildir:
30 ;; * Everything Just Works, and correctly. E.g., NOV data is automatically
31 ;; regenerated when stale; no need for manually running
32 ;; *-generate-nov-databases.
33 ;; * Perfect reliability: [C-g] will never corrupt its data in memory, and
34 ;; SIGKILL will never corrupt its data in the filesystem.
35 ;; * Allow concurrent operation as much as possible. If files change out
36 ;; from under us, adapt to the changes or degrade gracefully.
37 ;; * We use the filesystem as a database, so that, e.g., it's easy to
38 ;; manipulate marks from outside Gnus.
39 ;; * All information about a group is stored in the maildir, for easy backup,
40 ;; copying, restoring, etc.
43 ;; * When moving an article for expiry, copy all the marks except 'expire
44 ;; from the original article.
45 ;; * Add a hook for when moving messages from new/ to cur/, to support
46 ;; nnmail's duplicate detection.
47 ;; * Improve generated Xrefs, so crossposts are detectable.
48 ;; * Improve code readability.
52 ;; eval this before editing
54 (put 'nnmaildir--with-nntp-buffer
'lisp-indent-function
0)
55 (put 'nnmaildir--with-work-buffer
'lisp-indent-function
0)
56 (put 'nnmaildir--with-nov-buffer
'lisp-indent-function
0)
57 (put 'nnmaildir--with-move-buffer
'lisp-indent-function
0)
58 (put 'nnmaildir--condcase
'lisp-indent-function
2)
64 (unless (fboundp 'declare-function
) (defmacro declare-function
(&rest r
))))
78 (defconst nnmaildir-version
"Gnus")
80 (defvar nnmaildir-article-file-name nil
81 "*The filename of the most recently requested article. This variable is set
82 by nnmaildir-request-article.")
84 ;; The filename of the article being moved/copied:
85 (defvar nnmaildir--file nil
)
87 ;; Variables to generate filenames of messages being delivered:
88 (defvar nnmaildir--delivery-time
"")
89 (defconst nnmaildir--delivery-pid
(concat "P" (number-to-string (emacs-pid))))
90 (defvar nnmaildir--delivery-count nil
)
92 ;; An obarry containing symbols whose names are server names and whose values
94 (defvar nnmaildir--servers
(make-vector 3 0))
95 ;; The current server:
96 (defvar nnmaildir--cur-server nil
)
98 ;; A copy of nnmail-extra-headers
99 (defvar nnmaildir--extra nil
)
101 ;; A NOV structure looks like this (must be prin1-able, so no defstruct):
102 ["subject\tfrom\tdate"
103 "references\tchars\lines"
104 "To: you\tIn-Reply-To: <your.mess@ge>"
105 (12345 67890) ;; modtime of the corresponding article file
106 (to in-reply-to
)] ;; contemporary value of nnmail-extra-headers
107 (defconst nnmaildir--novlen
5)
108 (defmacro nnmaildir--nov-new
(beg mid end mtime extra
)
109 `(vector ,beg
,mid
,end
,mtime
,extra
))
110 (defmacro nnmaildir--nov-get-beg
(nov) `(aref ,nov
0))
111 (defmacro nnmaildir--nov-get-mid
(nov) `(aref ,nov
1))
112 (defmacro nnmaildir--nov-get-end
(nov) `(aref ,nov
2))
113 (defmacro nnmaildir--nov-get-mtime
(nov) `(aref ,nov
3))
114 (defmacro nnmaildir--nov-get-extra
(nov) `(aref ,nov
4))
115 (defmacro nnmaildir--nov-set-beg
(nov value
) `(aset ,nov
0 ,value
))
116 (defmacro nnmaildir--nov-set-mid
(nov value
) `(aset ,nov
1 ,value
))
117 (defmacro nnmaildir--nov-set-end
(nov value
) `(aset ,nov
2 ,value
))
118 (defmacro nnmaildir--nov-set-mtime
(nov value
) `(aset ,nov
3 ,value
))
119 (defmacro nnmaildir--nov-set-extra
(nov value
) `(aset ,nov
4 ,value
))
121 (defstruct nnmaildir--art
122 (prefix nil
:type string
) ;; "time.pid.host"
123 (suffix nil
:type string
) ;; ":2,flags"
124 (num nil
:type natnum
) ;; article number
125 (msgid nil
:type string
) ;; "<mess.age@id>"
126 (nov nil
:type vector
)) ;; cached nov structure, or nil
128 (defstruct nnmaildir--grp
129 (name nil
:type string
) ;; "group.name"
130 (new nil
:type list
) ;; new/ modtime
131 (cur nil
:type list
) ;; cur/ modtime
132 (min 1 :type natnum
) ;; minimum article number
133 (count 0 :type natnum
) ;; count of articles
134 (nlist nil
:type list
) ;; list of articles, ordered descending by number
135 (flist nil
:type vector
) ;; obarray mapping filename prefix->article
136 (mlist nil
:type vector
) ;; obarray mapping message-id->article
137 (cache nil
:type vector
) ;; nov cache
138 (index nil
:type natnum
) ;; index of next cache entry to replace
139 (mmth nil
:type vector
)) ;; obarray mapping mark name->dir modtime
140 ; ("Mark Mod Time Hash")
142 (defstruct nnmaildir--srv
143 (address nil
:type string
) ;; server address string
144 (method nil
:type list
) ;; (nnmaildir "address" ...)
145 (prefix nil
:type string
) ;; "nnmaildir+address:"
146 (dir nil
:type string
) ;; "/expanded/path/to/server/dir/"
147 (ls nil
:type function
) ;; directory-files function
148 (groups nil
:type vector
) ;; obarray mapping group name->group
149 (curgrp nil
:type nnmaildir--grp
) ;; current group, or nil
150 (error nil
:type string
) ;; last error message, or nil
151 (mtime nil
:type list
) ;; modtime of dir
152 (gnm nil
) ;; flag: split from mail-sources?
153 (target-prefix nil
:type string
)) ;; symlink target prefix
155 (defun nnmaildir--expired-article (group article
)
156 (setf (nnmaildir--art-nov article
) nil
)
157 (let ((flist (nnmaildir--grp-flist group
))
158 (mlist (nnmaildir--grp-mlist group
))
159 (min (nnmaildir--grp-min group
))
160 (count (1- (nnmaildir--grp-count group
)))
161 (prefix (nnmaildir--art-prefix article
))
162 (msgid (nnmaildir--art-msgid article
))
164 (nlist-pre '(nil . nil
))
166 (unless (zerop count
)
167 (setq nlist-post
(nnmaildir--grp-nlist group
)
168 num
(nnmaildir--art-num article
))
169 (if (eq num
(caar nlist-post
))
170 (setq new-nlist
(cdr nlist-post
))
171 (setq new-nlist nlist-post
173 nlist-post
(cdr nlist-post
))
174 (while (/= num
(caar nlist-post
))
175 (setq nlist-pre nlist-post
176 nlist-post
(cdr nlist-post
)))
177 (setq nlist-post
(cdr nlist-post
))
179 (setq min
(caar nlist-pre
)))))
180 (let ((inhibit-quit t
))
181 (setf (nnmaildir--grp-min group
) min
)
182 (setf (nnmaildir--grp-count group
) count
)
183 (setf (nnmaildir--grp-nlist group
) new-nlist
)
184 (setcdr nlist-pre nlist-post
)
185 (unintern prefix flist
)
186 (unintern msgid mlist
))))
188 (defun nnmaildir--nlist-art (group num
)
189 (let ((entry (assq num
(nnmaildir--grp-nlist group
))))
192 (defmacro nnmaildir--flist-art
(list file
)
193 `(symbol-value (intern-soft ,file
,list
)))
194 (defmacro nnmaildir--mlist-art
(list msgid
)
195 `(symbol-value (intern-soft ,msgid
,list
)))
197 (defun nnmaildir--pgname (server gname
)
198 (let ((prefix (nnmaildir--srv-prefix server
)))
199 (if prefix
(concat prefix gname
)
200 (setq gname
(gnus-group-prefixed-name gname
201 (nnmaildir--srv-method server
)))
202 (setf (nnmaildir--srv-prefix server
) (gnus-group-real-prefix gname
))
205 (defun nnmaildir--param (pgname param
)
206 (setq param
(gnus-group-find-parameter pgname param
'allow-list
))
207 (if (vectorp param
) (setq param
(aref param
0)))
210 (defmacro nnmaildir--with-nntp-buffer
(&rest body
)
212 (set-buffer nntp-server-buffer
)
214 (defmacro nnmaildir--with-work-buffer
(&rest body
)
216 (set-buffer (get-buffer-create " *nnmaildir work*"))
218 (defmacro nnmaildir--with-nov-buffer
(&rest body
)
220 (set-buffer (get-buffer-create " *nnmaildir nov*"))
222 (defmacro nnmaildir--with-move-buffer
(&rest body
)
224 (set-buffer (get-buffer-create " *nnmaildir move*"))
227 (defmacro nnmaildir--subdir
(dir subdir
)
228 `(file-name-as-directory (concat ,dir
,subdir
)))
229 (defmacro nnmaildir--srvgrp-dir
(srv-dir gname
)
230 `(nnmaildir--subdir ,srv-dir
,gname
))
231 (defmacro nnmaildir--tmp
(dir) `(nnmaildir--subdir ,dir
"tmp"))
232 (defmacro nnmaildir--new
(dir) `(nnmaildir--subdir ,dir
"new"))
233 (defmacro nnmaildir--cur
(dir) `(nnmaildir--subdir ,dir
"cur"))
234 (defmacro nnmaildir--nndir
(dir) `(nnmaildir--subdir ,dir
".nnmaildir"))
235 (defmacro nnmaildir--nov-dir
(dir) `(nnmaildir--subdir ,dir
"nov"))
236 (defmacro nnmaildir--marks-dir
(dir) `(nnmaildir--subdir ,dir
"marks"))
237 (defmacro nnmaildir--num-dir
(dir) `(nnmaildir--subdir ,dir
"num"))
239 (defmacro nnmaildir--unlink
(file-arg)
240 `(let ((file ,file-arg
))
241 (if (file-attributes file
) (delete-file file
))))
242 (defun nnmaildir--mkdir (dir)
243 (or (file-exists-p (file-name-as-directory dir
))
244 (make-directory-internal (directory-file-name dir
))))
245 (defun nnmaildir--mkfile (file)
246 (write-region "" nil file nil
'no-message
))
247 (defun nnmaildir--delete-dir-files (dir ls
)
248 (when (file-attributes dir
)
249 (mapc 'delete-file
(funcall ls dir
'full
"\\`[^.]" 'nosort
))
250 (delete-directory dir
)))
252 (defun nnmaildir--group-maxnum (server group
)
254 (if (zerop (nnmaildir--grp-count group
)) (throw 'return
0))
255 (let ((dir (nnmaildir--srvgrp-dir (nnmaildir--srv-dir server
)
256 (nnmaildir--grp-name group
)))
258 attr ino-opened nlink number-linked
)
259 (setq dir
(nnmaildir--nndir dir
)
260 dir
(nnmaildir--num-dir dir
))
262 (setq attr
(file-attributes
263 (concat dir
(number-to-string number-opened
))))
264 (or attr
(throw 'return
(1- number-opened
)))
265 (setq ino-opened
(nth 10 attr
)
267 number-linked
(+ number-opened nlink
))
268 (if (or (< nlink
1) (< number-linked nlink
))
269 (signal 'error
'("Arithmetic overflow")))
270 (setq attr
(file-attributes
271 (concat dir
(number-to-string number-linked
))))
272 (or attr
(throw 'return
(1- number-linked
)))
273 (if (/= ino-opened
(nth 10 attr
))
274 (setq number-opened number-linked
))))))
276 ;; Make the given server, if non-nil, be the current server. Then make the
277 ;; given group, if non-nil, be the current group of the current server. Then
278 ;; return the group object for the current group.
279 (defun nnmaildir--prepare (server group
)
283 (unless (setq server nnmaildir--cur-server
)
285 (unless (setq server
(intern-soft server nnmaildir--servers
))
287 (setq server
(symbol-value server
)
288 nnmaildir--cur-server server
))
289 (unless (setq groups
(nnmaildir--srv-groups server
))
291 (unless (nnmaildir--srv-method server
)
292 (setq x
(concat "nnmaildir:" (nnmaildir--srv-address server
))
293 x
(gnus-server-to-method x
))
294 (unless x
(throw 'return nil
))
295 (setf (nnmaildir--srv-method server
) x
))
297 (unless (setq group
(nnmaildir--srv-curgrp server
))
299 (unless (setq group
(intern-soft group groups
))
301 (setq group
(symbol-value group
)))
304 (defun nnmaildir--tab-to-space (string)
306 (while (string-match "\t" string pos
)
307 (aset string
(match-beginning 0) ?
)
308 (setq pos
(match-end 0))))
311 (defmacro nnmaildir--condcase
(errsym body
&rest handler
)
312 `(condition-case ,errsym
313 (let ((system-messages-locale "C")) ,body
)
316 (defun nnmaildir--emlink-p (err)
317 (and (eq (car err
) 'file-error
)
318 (string= (downcase (caddr err
)) "too many links")))
320 (defun nnmaildir--enoent-p (err)
321 (and (eq (car err
) 'file-error
)
322 (string= (downcase (caddr err
)) "no such file or directory")))
324 (defun nnmaildir--eexist-p (err)
325 (eq (car err
) 'file-already-exists
))
327 (defun nnmaildir--new-number (nndir)
328 "Allocate a new article number by atomically creating a file under NNDIR."
329 (let ((numdir (nnmaildir--num-dir nndir
))
332 number-link previous-number-link path-open path-link ino-open
)
333 (nnmaildir--mkdir numdir
)
336 (setq path-open
(concat numdir
(number-to-string number-open
)))
337 (if (not make-new-file
)
338 (setq previous-number-link number-link
)
339 (nnmaildir--mkfile path-open
)
340 ;; If Emacs had O_CREAT|O_EXCL, we could return number-open here.
341 (setq make-new-file nil
342 previous-number-link
0))
343 (let* ((attr (file-attributes path-open
))
344 (nlink (nth 1 attr
)))
345 (setq ino-open
(nth 10 attr
)
346 number-link
(+ number-open nlink
))
347 (if (or (< nlink
1) (< number-link nlink
))
348 (signal 'error
'("Arithmetic overflow"))))
349 (if (= number-link previous-number-link
)
350 ;; We've already tried this number, in the previous loop iteration,
352 (signal 'error
`("Corrupt internal nnmaildir data" ,path-open
)))
353 (setq path-link
(concat numdir
(number-to-string number-link
)))
354 (nnmaildir--condcase err
356 (add-name-to-file path-open path-link
)
357 (throw 'return number-link
))
359 ((nnmaildir--emlink-p err
)
360 (setq make-new-file t
361 number-open number-link
))
362 ((nnmaildir--eexist-p err
)
363 (let ((attr (file-attributes path-link
)))
364 (if (/= (nth 10 attr
) ino-open
)
365 (setq number-open number-link
367 (t (signal (car err
) (cdr err
)))))))))
369 (defun nnmaildir--update-nov (server group article
)
370 (let ((nnheader-file-coding-system 'binary
)
371 (srv-dir (nnmaildir--srv-dir server
))
372 (storage-version 1) ;; [version article-number msgid [...nov...]]
373 dir gname pgname msgdir prefix suffix file attr mtime novdir novfile
374 nov msgid nov-beg nov-mid nov-end field val old-extra num numdir
377 (setq gname
(nnmaildir--grp-name group
)
378 pgname
(nnmaildir--pgname server gname
)
379 dir
(nnmaildir--srvgrp-dir srv-dir gname
)
380 msgdir
(if (nnmaildir--param pgname
'read-only
)
381 (nnmaildir--new dir
) (nnmaildir--cur dir
))
382 prefix
(nnmaildir--art-prefix article
)
383 suffix
(nnmaildir--art-suffix article
)
384 file
(concat msgdir prefix suffix
)
385 attr
(file-attributes file
))
387 (nnmaildir--expired-article group article
)
389 (setq mtime
(nth 5 attr
)
391 nov
(nnmaildir--art-nov article
)
392 dir
(nnmaildir--nndir dir
)
393 novdir
(nnmaildir--nov-dir dir
)
394 novfile
(concat novdir prefix
))
395 (unless (equal nnmaildir--extra nnmail-extra-headers
)
396 (setq nnmaildir--extra
(copy-sequence nnmail-extra-headers
)))
397 (nnmaildir--with-nov-buffer
398 ;; First we'll check for already-parsed NOV data.
399 (cond ((not (file-exists-p novfile
))
400 ;; The NOV file doesn't exist; we have to parse the message.
403 ;; The file exists, but the data isn't in memory; read the file.
405 (nnheader-insert-file-contents novfile
)
406 (setq nov
(read (current-buffer)))
407 (if (not (and (vectorp nov
)
409 (equal storage-version
(aref nov
0))))
410 ;; This NOV data seems to be in the wrong format.
412 (unless (nnmaildir--art-num article
)
413 (setf (nnmaildir--art-num article
) (aref nov
1)))
414 (unless (nnmaildir--art-msgid article
)
415 (setf (nnmaildir--art-msgid article
) (aref nov
2)))
416 (setq nov
(aref nov
3)))))
417 ;; Now check whether the already-parsed data (if we have any) is
418 ;; usable: if the message has been edited or if nnmail-extra-headers
419 ;; has been augmented since this data was parsed from the message,
420 ;; then we have to reparse. Otherwise it's up-to-date.
421 (when (and nov
(equal mtime
(nnmaildir--nov-get-mtime nov
)))
422 ;; The timestamp matches. Now check nnmail-extra-headers.
423 (setq old-extra
(nnmaildir--nov-get-extra nov
))
424 (when (equal nnmaildir--extra old-extra
) ;; common case
425 ;; Save memory; use a single copy of the list value.
426 (nnmaildir--nov-set-extra nov nnmaildir--extra
)
428 ;; They're not equal, but maybe the new is a subset of the old.
429 (if (null nnmaildir--extra
)
430 ;; The empty set is a subset of every set.
432 (if (not (memq nil
(mapcar (lambda (e) (memq e old-extra
))
434 (throw 'return nov
)))
435 ;; Parse the NOV data out of the message.
437 (nnheader-insert-file-contents file
)
439 (goto-char (point-min))
441 (if (search-forward "\n\n" nil
'noerror
)
443 (setq nov-mid
(count-lines (point) (point-max)))
444 (narrow-to-region (point-min) (1- (point))))
446 (goto-char (point-min))
448 (setq nov
(nnheader-parse-naked-head)
449 field
(or (mail-header-lines nov
) 0)))
450 (unless (or (zerop field
) (nnmaildir--param pgname
'distrust-Lines
:))
451 (setq nov-mid field
))
452 (setq nov-mid
(number-to-string nov-mid
)
453 nov-mid
(concat (number-to-string attr
) "\t" nov-mid
))
455 (setq field
(or (mail-header-references nov
) ""))
456 (nnmaildir--tab-to-space field
)
457 (setq nov-mid
(concat field
"\t" nov-mid
)
459 (lambda (f) (nnmaildir--tab-to-space (or f
"")))
460 (list (mail-header-subject nov
)
461 (mail-header-from nov
)
462 (mail-header-date nov
)) "\t")
465 (setq field
(symbol-name (car extra
))
467 (nnmaildir--tab-to-space field
)
468 (nnmaildir--tab-to-space val
)
469 (concat field
": " val
))
470 (mail-header-extra nov
) "\t")))
471 (setq msgid
(mail-header-id nov
))
472 (if (or (null msgid
) (nnheader-fake-message-id-p msgid
))
473 (setq msgid
(concat "<" prefix
"@nnmaildir>")))
474 (nnmaildir--tab-to-space msgid
)
475 ;; The data is parsed; create an nnmaildir NOV structure.
476 (setq nov
(nnmaildir--nov-new nov-beg nov-mid nov-end mtime
478 num
(nnmaildir--art-num article
))
480 (setq num
(nnmaildir--new-number dir
))
481 (setf (nnmaildir--art-num article
) num
))
482 ;; Store this new NOV data in a file
484 (prin1 (vector storage-version num msgid nov
) (current-buffer))
485 (setq file
(concat novfile
":"))
486 (nnmaildir--unlink file
)
487 (gmm-write-region (point-min) (point-max) file nil
'no-message nil
489 (rename-file file novfile
'replace
)
490 (setf (nnmaildir--art-msgid article
) msgid
)
493 (defun nnmaildir--cache-nov (group article nov
)
494 (let ((cache (nnmaildir--grp-cache group
))
495 (index (nnmaildir--grp-index group
))
497 (unless (nnmaildir--art-nov article
)
498 (setq goner
(aref cache index
))
499 (if goner
(setf (nnmaildir--art-nov goner
) nil
))
500 (aset cache index article
)
501 (setf (nnmaildir--grp-index group
) (%
(1+ index
) (length cache
))))
502 (setf (nnmaildir--art-nov article
) nov
)))
504 (defun nnmaildir--grp-add-art (server group article
)
505 (let ((nov (nnmaildir--update-nov server group article
))
506 count num min nlist nlist-cdr insert-nlist
)
508 (setq count
(1+ (nnmaildir--grp-count group
))
509 num
(nnmaildir--art-num article
)
510 min
(if (= count
1) num
511 (min num
(nnmaildir--grp-min group
)))
512 nlist
(nnmaildir--grp-nlist group
))
513 (if (or (null nlist
) (> num
(caar nlist
)))
514 (setq nlist
(cons (cons num article
) nlist
))
516 nlist-cdr
(cdr nlist
))
517 (while (and nlist-cdr
(< num
(caar nlist-cdr
)))
518 (setq nlist nlist-cdr
519 nlist-cdr
(cdr nlist
))))
520 (let ((inhibit-quit t
))
521 (setf (nnmaildir--grp-count group
) count
)
522 (setf (nnmaildir--grp-min group
) min
)
524 (setcdr nlist
(cons (cons num article
) nlist-cdr
))
525 (setf (nnmaildir--grp-nlist group
) nlist
))
526 (set (intern (nnmaildir--art-prefix article
)
527 (nnmaildir--grp-flist group
))
529 (set (intern (nnmaildir--art-msgid article
)
530 (nnmaildir--grp-mlist group
))
532 (set (intern (nnmaildir--grp-name group
)
533 (nnmaildir--srv-groups server
))
535 (nnmaildir--cache-nov group article nov
)
538 (defun nnmaildir--group-ls (server pgname
)
539 (or (nnmaildir--param pgname
'directory-files
)
540 (nnmaildir--srv-ls server
)))
542 (defun nnmaildir-article-number-to-file-name
543 (number group-name server-address-string
)
544 (let ((group (nnmaildir--prepare server-address-string group-name
))
548 ;; The given group or server does not exist.
550 (setq article
(nnmaildir--nlist-art group number
))
552 ;; The given article number does not exist in this group.
554 (setq pgname
(nnmaildir--pgname nnmaildir--cur-server group-name
)
555 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
556 dir
(nnmaildir--srvgrp-dir dir group-name
)
557 dir
(if (nnmaildir--param pgname
'read-only
)
558 (nnmaildir--new dir
) (nnmaildir--cur dir
)))
559 (concat dir
(nnmaildir--art-prefix article
)
560 (nnmaildir--art-suffix article
)))))
562 (defun nnmaildir-article-number-to-base-name
563 (number group-name server-address-string
)
564 (let ((x (nnmaildir--prepare server-address-string group-name
)))
566 (setq x
(nnmaildir--nlist-art x number
))
567 (and x
(cons (nnmaildir--art-prefix x
)
568 (nnmaildir--art-suffix x
))))))
570 (defun nnmaildir-base-name-to-article-number
571 (base-name group-name server-address-string
)
572 (let ((x (nnmaildir--prepare server-address-string group-name
)))
574 (setq x
(nnmaildir--grp-flist x
)
575 x
(nnmaildir--flist-art x base-name
))
576 (and x
(nnmaildir--art-num x
)))))
578 (defun nnmaildir--nlist-iterate (nlist ranges func
)
579 (let (entry high low nlist2
)
581 (setq ranges
`((1 .
,(caar nlist
)))))
583 (setq entry
(car ranges
) ranges
(cdr ranges
))
584 (while (and ranges
(eq entry
(car ranges
)))
585 (setq ranges
(cdr ranges
))) ;; skip duplicates
589 (setq low
(car entry
)
591 (setq nlist2 nlist
) ;; Don't assume any sorting of ranges
594 (if (<= (caar nlist2
) high
) (throw 'iterate-loop nil
))
595 (setq nlist2
(cdr nlist2
))))
598 (setq entry
(car nlist2
) nlist2
(cdr nlist2
))
599 (if (< (car entry
) low
) (throw 'iterate-loop nil
))
600 (funcall func
(cdr entry
)))))))
602 (defun nnmaildir--up2-1 (n)
603 (if (zerop n
) 1 (1- (lsh 1 (1+ (logb n
))))))
605 (defun nnmaildir--system-name ()
606 (gnus-replace-in-string
607 (gnus-replace-in-string
608 (gnus-replace-in-string
610 "\\\\" "\\134" 'literal
)
611 "/" "\\057" 'literal
)
612 ":" "\\072" 'literal
))
614 (defun nnmaildir-request-type (group &optional article
)
617 (defun nnmaildir-status-message (&optional server
)
618 (nnmaildir--prepare server nil
)
619 (nnmaildir--srv-error nnmaildir--cur-server
))
621 (defun nnmaildir-server-opened (&optional server
)
622 (and nnmaildir--cur-server
624 (string-equal server
(nnmaildir--srv-address nnmaildir--cur-server
))
626 (nnmaildir--srv-groups nnmaildir--cur-server
)
629 (defun nnmaildir-open-server (server &optional defs
)
633 (setq server
(intern-soft x nnmaildir--servers
))
635 (and (setq server
(symbol-value server
))
636 (nnmaildir--srv-groups server
)
637 (setq nnmaildir--cur-server server
)
639 (setq server
(make-nnmaildir--srv :address x
))
640 (let ((inhibit-quit t
))
641 (set (intern x nnmaildir--servers
) server
)))
642 (setq dir
(assq 'directory defs
))
644 (setf (nnmaildir--srv-error server
)
645 "You must set \"directory\" in the select method")
649 dir
(expand-file-name dir
)
650 dir
(file-name-as-directory dir
))
651 (unless (file-exists-p dir
)
652 (setf (nnmaildir--srv-error server
) (concat "No such directory: " dir
))
654 (setf (nnmaildir--srv-dir server
) dir
)
655 (setq x
(assq 'directory-files defs
))
657 (setq x
(if nnheader-directory-files-is-safe
'directory-files
658 'nnheader-directory-files-safe
))
660 (unless (functionp x
)
661 (setf (nnmaildir--srv-error server
)
662 (concat "Not a function: " (prin1-to-string x
)))
663 (throw 'return nil
)))
664 (setf (nnmaildir--srv-ls server
) x
)
665 (setq size
(length (funcall x dir nil
"\\`[^.]" 'nosort
))
666 size
(nnmaildir--up2-1 size
))
667 (and (setq x
(assq 'get-new-mail defs
))
670 (setf (nnmaildir--srv-gnm server
) t
)
672 (setq x
(assq 'target-prefix defs
))
677 (setf (nnmaildir--srv-target-prefix server
) x
))
678 (setq x
(assq 'create-directory defs
))
683 x
(file-name-as-directory x
))
684 (setf (nnmaildir--srv-target-prefix server
) x
))
685 (setf (nnmaildir--srv-target-prefix server
) "")))
686 (setf (nnmaildir--srv-groups server
) (make-vector size
0))
687 (setq nnmaildir--cur-server server
)
690 (defun nnmaildir--parse-filename (file)
691 (let ((prefix (car file
))
693 (if (string-match "\\`\\([0-9]+\\)\\(\\..*\\)\\'" prefix
)
695 (setq timestamp
(concat "0000" (match-string 1 prefix
))
696 len
(- (length timestamp
) 4))
697 (vector (string-to-number (substring timestamp
0 len
))
698 (string-to-number (substring timestamp len
))
699 (match-string 2 prefix
)
703 (defun nnmaildir--sort-files (a b
)
706 (throw 'return
(and (consp b
) (string-lessp (car a
) (car b
)))))
707 (if (consp b
) (throw 'return t
))
708 (if (< (aref a
0) (aref b
0)) (throw 'return t
))
709 (if (> (aref a
0) (aref b
0)) (throw 'return nil
))
710 (if (< (aref a
1) (aref b
1)) (throw 'return t
))
711 (if (> (aref a
1) (aref b
1)) (throw 'return nil
))
712 (string-lessp (aref a
2) (aref b
2))))
714 (defun nnmaildir--scan (gname scan-msgs groups method srv-dir srv-ls
)
716 (let ((36h-ago (- (car (current-time)) 2))
717 absdir nndir tdir ndir cdir nattr cattr isnew pgname read-only ls
718 files num dir flist group x
)
719 (setq absdir
(nnmaildir--srvgrp-dir srv-dir gname
)
720 nndir
(nnmaildir--nndir absdir
))
721 (unless (file-exists-p absdir
)
722 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
723 (concat "No such directory: " absdir
))
725 (setq tdir
(nnmaildir--tmp absdir
)
726 ndir
(nnmaildir--new absdir
)
727 cdir
(nnmaildir--cur absdir
)
728 nattr
(file-attributes ndir
)
729 cattr
(file-attributes cdir
))
730 (unless (and (file-exists-p tdir
) nattr cattr
)
731 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
732 (concat "Not a maildir: " absdir
))
734 (setq group
(nnmaildir--prepare nil gname
)
735 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
))
739 group
(make-nnmaildir--grp :name gname
:index
0))
740 (nnmaildir--mkdir nndir
)
741 (nnmaildir--mkdir (nnmaildir--nov-dir nndir
))
742 (nnmaildir--mkdir (nnmaildir--marks-dir nndir
)))
743 (setq read-only
(nnmaildir--param pgname
'read-only
)
744 ls
(or (nnmaildir--param pgname
'directory-files
) srv-ls
))
746 (setq x
(nth 11 (file-attributes tdir
)))
747 (unless (and (= x
(nth 11 nattr
)) (= x
(nth 11 cattr
)))
748 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
749 (concat "Maildir spans filesystems: " absdir
))
751 (dolist (file (funcall ls tdir
'full
"\\`[^.]" 'nosort
))
752 (setq x
(file-attributes file
))
753 (if (or (> (cadr x
) 1) (< (car (nth 4 x
)) 36h-ago
))
754 (delete-file file
))))
758 (setq nattr
(nth 5 nattr
))
759 (if (equal nattr
(nnmaildir--grp-new group
))
761 (if read-only
(setq dir
(and (or isnew nattr
) ndir
))
762 (when (or isnew nattr
)
763 (dolist (file (funcall ls ndir nil
"\\`[^.]" 'nosort
))
764 (setq x
(concat ndir file
))
765 (and (time-less-p (nth 5 (file-attributes x
)) (current-time))
766 (rename-file x
(concat cdir file
":2,"))))
767 (setf (nnmaildir--grp-new group
) nattr
))
768 (setq cattr
(nth 5 (file-attributes cdir
)))
769 (if (equal cattr
(nnmaildir--grp-cur group
))
771 (setq dir
(and (or isnew cattr
) cdir
)))
772 (unless dir
(throw 'return t
))
773 (setq files
(funcall ls dir nil
"\\`[^.]" 'nosort
)
774 files
(save-match-data
777 (string-match "\\`\\([^:]*\\)\\(\\(:.*\\)?\\)\\'" f
)
778 (cons (match-string 1 f
) (match-string 2 f
)))
781 (setq num
(nnmaildir--up2-1 (length files
)))
782 (setf (nnmaildir--grp-flist group
) (make-vector num
0))
783 (setf (nnmaildir--grp-mlist group
) (make-vector num
0))
784 (setf (nnmaildir--grp-mmth group
) (make-vector 1 0))
785 (setq num
(nnmaildir--param pgname
'nov-cache-size
))
786 (if (numberp num
) (if (< num
1) (setq num
1))
788 cdir
(nnmaildir--marks-dir nndir
)
789 ndir
(nnmaildir--subdir cdir
"tick")
790 cdir
(nnmaildir--subdir cdir
"read"))
792 (setq file
(car file
))
793 (if (or (not (file-exists-p (concat cdir file
)))
794 (file-exists-p (concat ndir file
)))
795 (setq num
(1+ num
)))))
796 (setf (nnmaildir--grp-cache group
) (make-vector num nil
))
797 (let ((inhibit-quit t
))
798 (set (intern gname groups
) group
))
799 (or scan-msgs
(throw 'return t
)))
800 (setq flist
(nnmaildir--grp-flist group
)
803 (and (null (nnmaildir--flist-art flist
(car file
)))
806 files
(delq nil files
)
807 files
(mapcar 'nnmaildir--parse-filename files
)
808 files
(sort files
'nnmaildir--sort-files
))
810 (setq file
(if (consp file
) file
(aref file
3))
811 x
(make-nnmaildir--art :prefix
(car file
) :suffix
(cdr file
)))
812 (nnmaildir--grp-add-art nnmaildir--cur-server group x
))
813 (if read-only
(setf (nnmaildir--grp-new group
) nattr
)
814 (setf (nnmaildir--grp-cur group
) cattr
)))
817 (defun nnmaildir-request-scan (&optional scan-group server
)
818 (let ((coding-system-for-write nnheader-file-coding-system
)
819 (buffer-file-coding-system nil
)
820 (file-coding-system-alist nil
)
821 (nnmaildir-get-new-mail t
)
822 (nnmaildir-group-alist nil
)
823 (nnmaildir-active-file nil
)
824 x srv-ls srv-dir method groups target-prefix group dirs grp-dir seen
826 (nnmaildir--prepare server nil
)
827 (setq srv-ls
(nnmaildir--srv-ls nnmaildir--cur-server
)
828 srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
829 method
(nnmaildir--srv-method nnmaildir--cur-server
)
830 groups
(nnmaildir--srv-groups nnmaildir--cur-server
)
831 target-prefix
(nnmaildir--srv-target-prefix nnmaildir--cur-server
))
832 (nnmaildir--with-work-buffer
834 (if (stringp scan-group
)
835 (if (nnmaildir--scan scan-group t groups method srv-dir srv-ls
)
836 (if (nnmaildir--srv-gnm nnmaildir--cur-server
)
837 (nnmail-get-new-mail 'nnmaildir nil nil scan-group
))
838 (unintern scan-group groups
))
839 (setq x
(nth 5 (file-attributes srv-dir
))
840 scan-group
(null scan-group
))
841 (if (equal x
(nnmaildir--srv-mtime nnmaildir--cur-server
))
843 (mapatoms (lambda (sym)
844 (nnmaildir--scan (symbol-name sym
) t groups
845 method srv-dir srv-ls
))
847 (setq dirs
(funcall srv-ls srv-dir nil
"\\`[^.]" 'nosort
)
848 dirs
(if (zerop (length target-prefix
))
852 (and (>= (length dir
) (length target-prefix
))
853 (string= (substring dir
0
854 (length target-prefix
))
857 seen
(nnmaildir--up2-1 (length dirs
))
858 seen
(make-vector seen
0))
859 (dolist (grp-dir dirs
)
860 (if (nnmaildir--scan grp-dir scan-group groups method srv-dir
862 (intern grp-dir seen
)))
864 (mapatoms (lambda (group)
865 (setq group
(symbol-name group
))
866 (unless (intern-soft group seen
)
867 (setq x
(cons group x
))))
870 (unintern grp groups
))
871 (setf (nnmaildir--srv-mtime nnmaildir--cur-server
)
872 (nth 5 (file-attributes srv-dir
))))
874 (nnmaildir--srv-gnm nnmaildir--cur-server
)
875 (nnmail-get-new-mail 'nnmaildir nil nil
))))))
878 (defun nnmaildir-request-list (&optional server
)
879 (nnmaildir-request-scan 'find-new-groups server
)
880 (let (pgname ro deactivate-mark
)
881 (nnmaildir--prepare server nil
)
882 (nnmaildir--with-nntp-buffer
884 (mapatoms (lambda (group)
885 (setq pgname
(symbol-name group
)
886 pgname
(nnmaildir--pgname nnmaildir--cur-server pgname
)
887 group
(symbol-value group
)
888 ro
(nnmaildir--param pgname
'read-only
))
889 (insert (gnus-replace-in-string
890 (nnmaildir--grp-name group
) " " "\\ " t
)
892 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group
)
895 (princ (nnmaildir--grp-min group
) nntp-server-buffer
)
896 (insert " " (if ro
"n" "y") "\n"))
897 (nnmaildir--srv-groups nnmaildir--cur-server
))))
900 (defun nnmaildir-request-newgroups (date &optional server
)
901 (nnmaildir-request-list server
))
903 (defun nnmaildir-retrieve-groups (groups &optional server
)
904 (let (group deactivate-mark
)
905 (nnmaildir--prepare server nil
)
906 (nnmaildir--with-nntp-buffer
908 (dolist (gname groups
)
909 (setq group
(nnmaildir--prepare nil gname
))
910 (if (null group
) (insert "411 no such news group\n")
912 (princ (nnmaildir--grp-count group
) nntp-server-buffer
)
914 (princ (nnmaildir--grp-min group
) nntp-server-buffer
)
916 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group
)
919 (gnus-replace-in-string gname
" " "\\ " t
)
923 (defun nnmaildir-request-update-info (gname info
&optional server
)
924 (let ((group (nnmaildir--prepare server gname
))
925 pgname flist always-marks never-marks old-marks dotfile num dir
926 markdirs marks mark ranges markdir article read end new-marks ls
927 old-mmth new-mmth mtime mark-sym existing missing deactivate-mark
931 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
932 (concat "No such group: " gname
))
934 (setq gname
(nnmaildir--grp-name group
)
935 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
936 flist
(nnmaildir--grp-flist group
))
937 (when (zerop (nnmaildir--grp-count group
))
938 (gnus-info-set-read info nil
)
939 (gnus-info-set-marks info nil
'extend
)
940 (throw 'return info
))
941 (setq old-marks
(cons 'read
(gnus-info-read info
))
942 old-marks
(cons old-marks
(gnus-info-marks info
))
943 always-marks
(nnmaildir--param pgname
'always-marks
)
944 never-marks
(nnmaildir--param pgname
'never-marks
)
945 existing
(nnmaildir--grp-nlist group
)
946 existing
(mapcar 'car existing
)
947 existing
(nreverse existing
)
948 existing
(gnus-compress-sequence existing
'always-list
)
949 missing
(list (cons 1 (nnmaildir--group-maxnum
950 nnmaildir--cur-server group
)))
951 missing
(gnus-range-difference missing existing
)
952 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
953 dir
(nnmaildir--srvgrp-dir dir gname
)
954 dir
(nnmaildir--nndir dir
)
955 dir
(nnmaildir--marks-dir dir
)
956 ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
)
957 markdirs
(funcall ls dir nil
"\\`[^.]" 'nosort
)
958 new-mmth
(nnmaildir--up2-1 (length markdirs
))
959 new-mmth
(make-vector new-mmth
0)
960 old-mmth
(nnmaildir--grp-mmth group
))
961 (dolist (mark markdirs
)
962 (setq markdir
(nnmaildir--subdir dir mark
)
963 mark-sym
(intern mark
)
966 (if (memq mark-sym never-marks
) (throw 'got-ranges nil
))
967 (when (memq mark-sym always-marks
)
968 (setq ranges existing
)
969 (throw 'got-ranges nil
))
970 (setq mtime
(nth 5 (file-attributes markdir
)))
971 (set (intern mark new-mmth
) mtime
)
972 (when (equal mtime
(symbol-value (intern-soft mark old-mmth
)))
973 (setq ranges
(assq mark-sym old-marks
))
974 (if ranges
(setq ranges
(cdr ranges
)))
975 (throw 'got-ranges nil
))
976 (setq article-list nil
)
977 (dolist (prefix (funcall ls markdir nil
"\\`[^.]" 'nosort
))
978 (setq article
(nnmaildir--flist-art flist prefix
))
981 (cons (nnmaildir--art-num article
) article-list
))))
982 (setq ranges
(gnus-add-to-range ranges
(sort article-list
'<))))
983 (if (eq mark-sym
'read
) (setq read ranges
)
984 (if ranges
(setq marks
(cons (cons mark-sym ranges
) marks
)))))
985 (gnus-info-set-read info
(gnus-range-add read missing
))
986 (gnus-info-set-marks info marks
'extend
)
987 (setf (nnmaildir--grp-mmth group
) new-mmth
)
990 (defun nnmaildir-request-group (gname &optional server fast
)
991 (let ((group (nnmaildir--prepare server gname
))
995 ;; (insert "411 no such news group\n")
996 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
997 (concat "No such group: " gname
))
999 (setf (nnmaildir--srv-curgrp nnmaildir--cur-server
) group
)
1000 (if fast
(throw 'return t
))
1001 (nnmaildir--with-nntp-buffer
1004 (princ (nnmaildir--grp-count group
) nntp-server-buffer
)
1006 (princ (nnmaildir--grp-min group
) nntp-server-buffer
)
1008 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group
)
1010 (insert " " (gnus-replace-in-string gname
" " "\\ " t
) "\n")
1013 (defun nnmaildir-request-create-group (gname &optional server args
)
1014 (nnmaildir--prepare server nil
)
1016 (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server
))
1018 (when (zerop (length gname
))
1019 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1020 "Invalid (empty) group name")
1021 (throw 'return nil
))
1022 (when (eq (aref "." 0) (aref gname
0))
1023 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1024 "Group names may not start with \".\"")
1025 (throw 'return nil
))
1026 (when (save-match-data (string-match "[\0/\t]" gname
))
1027 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1028 (concat "Invalid characters (null, tab, or /) in group name: "
1030 (throw 'return nil
))
1031 (setq groups
(nnmaildir--srv-groups nnmaildir--cur-server
))
1032 (when (intern-soft gname groups
)
1033 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1034 (concat "Group already exists: " gname
))
1035 (throw 'return nil
))
1036 (setq srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
))
1037 (if (file-name-absolute-p target-prefix
)
1038 (setq dir
(expand-file-name target-prefix
))
1040 dir
(file-truename dir
)
1041 dir
(concat dir target-prefix
)))
1042 (setq dir
(nnmaildir--subdir dir gname
))
1043 (nnmaildir--mkdir dir
)
1044 (nnmaildir--mkdir (nnmaildir--tmp dir
))
1045 (nnmaildir--mkdir (nnmaildir--new dir
))
1046 (nnmaildir--mkdir (nnmaildir--cur dir
))
1047 (unless (string= target-prefix
"")
1048 (make-symbolic-link (concat target-prefix gname
)
1049 (concat srv-dir gname
)))
1050 (nnmaildir-request-scan 'find-new-groups
))))
1052 (defun nnmaildir-request-rename-group (gname new-name
&optional server
)
1053 (let ((group (nnmaildir--prepare server gname
))
1054 (coding-system-for-write nnheader-file-coding-system
)
1055 (buffer-file-coding-system nil
)
1056 (file-coding-system-alist nil
)
1060 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1061 (concat "No such group: " gname
))
1062 (throw 'return nil
))
1063 (when (zerop (length new-name
))
1064 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1065 "Invalid (empty) group name")
1066 (throw 'return nil
))
1067 (when (eq (aref "." 0) (aref new-name
0))
1068 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1069 "Group names may not start with \".\"")
1070 (throw 'return nil
))
1071 (when (save-match-data (string-match "[\0/\t]" new-name
))
1072 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1073 (concat "Invalid characters (null, tab, or /) in group name: "
1075 (throw 'return nil
))
1076 (if (string-equal gname new-name
) (throw 'return t
))
1077 (when (intern-soft new-name
1078 (nnmaildir--srv-groups nnmaildir--cur-server
))
1079 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1080 (concat "Group already exists: " new-name
))
1081 (throw 'return nil
))
1082 (setq srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
))
1084 (rename-file (concat srv-dir gname
)
1085 (concat srv-dir new-name
))
1087 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1088 (concat "Error renaming link: " (prin1-to-string err
)))
1089 (throw 'return nil
)))
1090 (setq x
(nnmaildir--srv-groups nnmaildir--cur-server
)
1091 groups
(make-vector (length x
) 0))
1092 (mapatoms (lambda (sym)
1093 (unless (eq (symbol-value sym
) group
)
1094 (set (intern (symbol-name sym
) groups
)
1095 (symbol-value sym
))))
1097 (setq group
(copy-sequence group
))
1098 (setf (nnmaildir--grp-name group
) new-name
)
1099 (set (intern new-name groups
) group
)
1100 (setf (nnmaildir--srv-groups nnmaildir--cur-server
) groups
)
1103 (defun nnmaildir-request-delete-group (gname force
&optional server
)
1104 (let ((group (nnmaildir--prepare server gname
))
1105 pgname grp-dir target dir ls deactivate-mark
)
1108 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1109 (concat "No such group: " gname
))
1110 (throw 'return nil
))
1111 (setq gname
(nnmaildir--grp-name group
)
1112 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1113 grp-dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1114 target
(car (file-attributes (concat grp-dir gname
)))
1115 grp-dir
(nnmaildir--srvgrp-dir grp-dir gname
))
1116 (unless (or force
(stringp target
))
1117 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1118 (concat "Not a symlink: " gname
))
1119 (throw 'return nil
))
1120 (if (eq group
(nnmaildir--srv-curgrp nnmaildir--cur-server
))
1121 (setf (nnmaildir--srv-curgrp nnmaildir--cur-server
) nil
))
1122 (unintern gname
(nnmaildir--srv-groups nnmaildir--cur-server
))
1125 (setq grp-dir
(directory-file-name grp-dir
))
1126 (nnmaildir--unlink grp-dir
))
1127 (setq ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
))
1128 (if (nnmaildir--param pgname
'read-only
)
1129 (progn (delete-directory (nnmaildir--tmp grp-dir
))
1130 (nnmaildir--unlink (nnmaildir--new grp-dir
))
1131 (delete-directory (nnmaildir--cur grp-dir
)))
1132 (nnmaildir--delete-dir-files (nnmaildir--tmp grp-dir
) ls
)
1133 (nnmaildir--delete-dir-files (nnmaildir--new grp-dir
) ls
)
1134 (nnmaildir--delete-dir-files (nnmaildir--cur grp-dir
) ls
))
1135 (setq dir
(nnmaildir--nndir grp-dir
))
1136 (dolist (subdir `(,(nnmaildir--nov-dir dir
) ,(nnmaildir--num-dir dir
)
1137 ,@(funcall ls
(nnmaildir--marks-dir dir
)
1138 'full
"\\`[^.]" 'nosort
)))
1139 (nnmaildir--delete-dir-files subdir ls
))
1140 (setq dir
(nnmaildir--nndir grp-dir
))
1141 (nnmaildir--unlink (concat dir
"markfile"))
1142 (nnmaildir--unlink (concat dir
"markfile{new}"))
1143 (delete-directory (nnmaildir--marks-dir dir
))
1144 (delete-directory dir
)
1145 (if (not (stringp target
))
1146 (delete-directory grp-dir
)
1147 (setq grp-dir
(directory-file-name grp-dir
)
1149 (unless (eq (aref "/" 0) (aref dir
0))
1150 (setq dir
(concat (file-truename
1151 (nnmaildir--srv-dir nnmaildir--cur-server
))
1153 (delete-directory dir
)
1154 (nnmaildir--unlink grp-dir
)))
1157 (defun nnmaildir-retrieve-headers (articles &optional gname server fetch-old
)
1158 (let ((group (nnmaildir--prepare server gname
))
1159 srv-dir dir nlist mlist article num start stop nov nlist2 insert-nov
1163 (setq nov
(nnmaildir--update-nov nnmaildir--cur-server group
1166 (nnmaildir--cache-nov group article nov
)
1167 (setq num
(nnmaildir--art-num article
))
1168 (princ num nntp-server-buffer
)
1169 (insert "\t" (nnmaildir--nov-get-beg nov
) "\t"
1170 (nnmaildir--art-msgid article
) "\t"
1171 (nnmaildir--nov-get-mid nov
) "\tXref: nnmaildir "
1172 (gnus-replace-in-string gname
" " "\\ " t
) ":")
1173 (princ num nntp-server-buffer
)
1174 (insert "\t" (nnmaildir--nov-get-end nov
) "\n"))))
1177 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1178 (if gname
(concat "No such group: " gname
) "No current group"))
1179 (throw 'return nil
))
1180 (nnmaildir--with-nntp-buffer
1182 (setq mlist
(nnmaildir--grp-mlist group
)
1183 nlist
(nnmaildir--grp-nlist group
)
1184 gname
(nnmaildir--grp-name group
)
1185 srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1186 dir
(nnmaildir--srvgrp-dir srv-dir gname
))
1189 ((and fetch-old
(not (numberp fetch-old
)))
1190 (nnmaildir--nlist-iterate nlist
'all insert-nov
))
1192 ((stringp (car articles
))
1193 (dolist (msgid articles
)
1194 (setq article
(nnmaildir--mlist-art mlist msgid
))
1195 (if article
(funcall insert-nov article
))))
1198 ;; Assume the article range list is sorted ascending
1199 (setq stop
(car articles
)
1200 start
(car (last articles
))
1201 stop
(if (numberp stop
) stop
(car stop
))
1202 start
(if (numberp start
) start
(cdr start
))
1203 stop
(- stop fetch-old
)
1204 stop
(if (< stop
1) 1 stop
)
1205 articles
(list (cons stop start
))))
1206 (nnmaildir--nlist-iterate nlist articles insert-nov
)))
1207 (sort-numeric-fields 1 (point-min) (point-max))
1210 (defun nnmaildir-request-article (num-msgid &optional gname server to-buffer
)
1211 (let ((group (nnmaildir--prepare server gname
))
1212 (case-fold-search t
)
1213 list article dir pgname deactivate-mark
)
1216 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1217 (if gname
(concat "No such group: " gname
) "No current group"))
1218 (throw 'return nil
))
1219 (if (numberp num-msgid
)
1220 (setq article
(nnmaildir--nlist-art group num-msgid
))
1221 (setq list
(nnmaildir--grp-mlist group
)
1222 article
(nnmaildir--mlist-art list num-msgid
))
1223 (if article
(setq num-msgid
(nnmaildir--art-num article
))
1227 (setq group
(symbol-value group-sym
)
1228 list
(nnmaildir--grp-mlist group
)
1229 article
(nnmaildir--mlist-art list num-msgid
))
1231 (setq num-msgid
(nnmaildir--art-num article
))
1232 (throw 'found nil
)))
1233 (nnmaildir--srv-groups nnmaildir--cur-server
))))
1235 (setf (nnmaildir--srv-error nnmaildir--cur-server
) "No such article")
1236 (throw 'return nil
)))
1237 (setq gname
(nnmaildir--grp-name group
)
1238 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1239 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1240 dir
(nnmaildir--srvgrp-dir dir gname
)
1241 dir
(if (nnmaildir--param pgname
'read-only
)
1242 (nnmaildir--new dir
) (nnmaildir--cur dir
))
1243 nnmaildir-article-file-name
1245 (nnmaildir--art-prefix article
)
1246 (nnmaildir--art-suffix article
)))
1247 (unless (file-exists-p nnmaildir-article-file-name
)
1248 (nnmaildir--expired-article group article
)
1249 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1250 "Article has expired")
1251 (throw 'return nil
))
1253 (set-buffer (or to-buffer nntp-server-buffer
))
1255 (nnheader-insert-file-contents nnmaildir-article-file-name
))
1256 (cons gname num-msgid
))))
1258 (defun nnmaildir-request-post (&optional server
)
1259 (let (message-required-mail-headers)
1260 (funcall message-send-mail-function
)))
1262 (defun nnmaildir-request-replace-article (number gname buffer
)
1263 (let ((group (nnmaildir--prepare nil gname
))
1264 (coding-system-for-write nnheader-file-coding-system
)
1265 (buffer-file-coding-system nil
)
1266 (file-coding-system-alist nil
)
1267 dir file article suffix tmpfile deactivate-mark
)
1270 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1271 (concat "No such group: " gname
))
1272 (throw 'return nil
))
1273 (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname
)
1275 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1276 (concat "Read-only group: " group
))
1277 (throw 'return nil
))
1278 (setq dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1279 dir
(nnmaildir--srvgrp-dir dir gname
)
1280 article
(nnmaildir--nlist-art group number
))
1282 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1283 (concat "No such article: " (number-to-string number
)))
1284 (throw 'return nil
))
1285 (setq suffix
(nnmaildir--art-suffix article
)
1286 file
(nnmaildir--art-prefix article
)
1287 tmpfile
(concat (nnmaildir--tmp dir
) file
))
1288 (when (file-exists-p tmpfile
)
1289 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1290 (concat "File exists: " tmpfile
))
1291 (throw 'return nil
))
1294 (gmm-write-region (point-min) (point-max) tmpfile nil
'no-message nil
1296 (unix-sync) ;; no fsync :(
1297 (rename-file tmpfile
(concat (nnmaildir--cur dir
) file suffix
) 'replace
)
1300 (defun nnmaildir-request-move-article (article gname server accept-form
1301 &optional last move-is-internal
)
1302 (let ((group (nnmaildir--prepare server gname
))
1303 pgname suffix result nnmaildir--file deactivate-mark
)
1306 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1307 (concat "No such group: " gname
))
1308 (throw 'return nil
))
1309 (setq gname
(nnmaildir--grp-name group
)
1310 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1311 article
(nnmaildir--nlist-art group article
))
1313 (setf (nnmaildir--srv-error nnmaildir--cur-server
) "No such article")
1314 (throw 'return nil
))
1315 (setq suffix
(nnmaildir--art-suffix article
)
1316 nnmaildir--file
(nnmaildir--srv-dir nnmaildir--cur-server
)
1317 nnmaildir--file
(nnmaildir--srvgrp-dir nnmaildir--file gname
)
1318 nnmaildir--file
(if (nnmaildir--param pgname
'read-only
)
1319 (nnmaildir--new nnmaildir--file
)
1320 (nnmaildir--cur nnmaildir--file
))
1321 nnmaildir--file
(concat nnmaildir--file
1322 (nnmaildir--art-prefix article
)
1324 (unless (file-exists-p nnmaildir--file
)
1325 (nnmaildir--expired-article group article
)
1326 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1327 "Article has expired")
1328 (throw 'return nil
))
1329 (nnmaildir--with-move-buffer
1331 (nnheader-insert-file-contents nnmaildir--file
)
1332 (setq result
(eval accept-form
)))
1333 (unless (or (null result
) (nnmaildir--param pgname
'read-only
))
1334 (nnmaildir--unlink nnmaildir--file
)
1335 (nnmaildir--expired-article group article
))
1338 (defun nnmaildir-request-accept-article (gname &optional server last
)
1339 (let ((group (nnmaildir--prepare server gname
))
1340 (coding-system-for-write nnheader-file-coding-system
)
1341 (buffer-file-coding-system nil
)
1342 (file-coding-system-alist nil
)
1343 srv-dir dir file time tmpfile curfile
24h article
)
1346 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1347 (concat "No such group: " gname
))
1348 (throw 'return nil
))
1349 (setq gname
(nnmaildir--grp-name group
))
1350 (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname
)
1352 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1353 (concat "Read-only group: " gname
))
1354 (throw 'return nil
))
1355 (setq srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1356 dir
(nnmaildir--srvgrp-dir srv-dir gname
)
1358 file
(format-time-string "%s." time
))
1359 (unless (string-equal nnmaildir--delivery-time file
)
1360 (setq nnmaildir--delivery-time file
1361 nnmaildir--delivery-count
0))
1362 (when (and (consp (cdr time
))
1363 (consp (cddr time
)))
1364 (setq file
(concat file
"M" (number-to-string (caddr time
)))))
1365 (setq file
(concat file nnmaildir--delivery-pid
)
1366 file
(concat file
"Q" (number-to-string nnmaildir--delivery-count
))
1367 file
(concat file
"." (nnmaildir--system-name))
1368 tmpfile
(concat (nnmaildir--tmp dir
) file
)
1369 curfile
(concat (nnmaildir--cur dir
) file
":2,"))
1370 (when (file-exists-p tmpfile
)
1371 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1372 (concat "File exists: " tmpfile
))
1373 (throw 'return nil
))
1374 (when (file-exists-p curfile
)
1375 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1376 (concat "File exists: " curfile
))
1377 (throw 'return nil
))
1378 (setq nnmaildir--delivery-count
(1+ nnmaildir--delivery-count
)
1379 24h
(run-with-timer 86400 nil
1381 (nnmaildir--unlink tmpfile
)
1382 (setf (nnmaildir--srv-error
1383 nnmaildir--cur-server
)
1384 "24-hour timer expired")
1385 (throw 'return nil
))))
1386 (condition-case nil
(add-name-to-file nnmaildir--file tmpfile
)
1388 (gmm-write-region (point-min) (point-max) tmpfile nil
'no-message nil
1390 (unix-sync))) ;; no fsync :(
1391 (nnheader-cancel-timer 24h
)
1393 (add-name-to-file tmpfile curfile
)
1395 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1396 (concat "Error linking: " (prin1-to-string err
)))
1397 (nnmaildir--unlink tmpfile
)
1398 (throw 'return nil
)))
1399 (nnmaildir--unlink tmpfile
)
1400 (setq article
(make-nnmaildir--art :prefix file
:suffix
":2,"))
1401 (if (nnmaildir--grp-add-art nnmaildir--cur-server group article
)
1402 (cons gname
(nnmaildir--art-num article
))))))
1404 (defun nnmaildir-save-mail (group-art)
1407 (throw 'return nil
))
1408 (let (ga gname x groups nnmaildir--file deactivate-mark
)
1410 (goto-char (point-min))
1412 (while (looking-at "From ")
1413 (replace-match "X-From-Line: ")
1415 (setq groups
(nnmaildir--srv-groups nnmaildir--cur-server
)
1416 ga
(car group-art
) group-art
(cdr group-art
)
1418 (or (intern-soft gname groups
)
1419 (nnmaildir-request-create-group gname
)
1420 (throw 'return nil
)) ;; not that nnmail bothers to check :(
1421 (unless (nnmaildir-request-accept-article gname
)
1422 (throw 'return nil
))
1423 (setq nnmaildir--file
(nnmaildir--srv-dir nnmaildir--cur-server
)
1424 nnmaildir--file
(nnmaildir--srvgrp-dir nnmaildir--file gname
)
1425 x
(nnmaildir--prepare nil gname
)
1426 x
(nnmaildir--grp-nlist x
)
1428 nnmaildir--file
(concat nnmaildir--file
1429 (nnmaildir--art-prefix x
)
1430 (nnmaildir--art-suffix x
)))
1434 (setq gname
(car ga
))
1435 (and (or (intern-soft gname groups
)
1436 (nnmaildir-request-create-group gname
))
1437 (nnmaildir-request-accept-article gname
)
1441 (defun nnmaildir-active-number (gname)
1444 (declare-function gnus-group-mark-article-read
"gnus-group" (group article
))
1446 (defun nnmaildir-request-expire-articles (ranges &optional gname server force
)
1447 (let ((no-force (not force
))
1448 (group (nnmaildir--prepare server gname
))
1449 pgname time boundary bound-iter high low target dir nlist nlist2
1450 stop article didnt nnmaildir--file nnmaildir-article-file-name
1454 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1455 (if gname
(concat "No such group: " gname
) "No current group"))
1456 (throw 'return
(gnus-uncompress-range ranges
)))
1457 (setq gname
(nnmaildir--grp-name group
)
1458 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
))
1459 (if (nnmaildir--param pgname
'read-only
)
1460 (throw 'return
(gnus-uncompress-range ranges
)))
1461 (setq time
(nnmaildir--param pgname
'expire-age
))
1463 (setq time
(or (and nnmail-expiry-wait-function
1464 (funcall nnmail-expiry-wait-function gname
))
1465 nnmail-expiry-wait
))
1466 (if (eq time
'immediate
)
1469 (setq time
(* time
86400)))))
1471 (unless (integerp time
) ;; handle 'never
1472 (throw 'return
(gnus-uncompress-range ranges
)))
1473 (setq boundary
(current-time)
1474 high
(- (car boundary
) (/ time
65536))
1475 low
(- (cadr boundary
) (% time
65536)))
1477 (setq low
(+ low
65536)
1479 (setcar (cdr boundary
) low
)
1480 (setcar boundary high
))
1481 (setq dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1482 dir
(nnmaildir--srvgrp-dir dir gname
)
1483 dir
(nnmaildir--cur dir
)
1484 nlist
(nnmaildir--grp-nlist group
)
1485 ranges
(reverse ranges
))
1486 (nnmaildir--with-move-buffer
1487 (nnmaildir--nlist-iterate
1490 (setq nnmaildir--file
(nnmaildir--art-prefix article
)
1491 nnmaildir--file
(concat dir nnmaildir--file
1492 (nnmaildir--art-suffix article
))
1493 time
(file-attributes nnmaildir--file
))
1496 (nnmaildir--expired-article group article
))
1499 (setq time
(nth 5 time
)
1500 bound-iter boundary
)
1501 (while (and bound-iter time
1502 (= (car bound-iter
) (car time
)))
1503 (setq bound-iter
(cdr bound-iter
)
1505 (and bound-iter time
1506 (car-less-than-car bound-iter time
))))
1507 (setq didnt
(cons (nnmaildir--art-num article
) didnt
)))
1509 (setq nnmaildir-article-file-name nnmaildir--file
1510 target
(if force nil
1513 (nnmaildir--param pgname
'expire-group
)))))
1514 (when (and (stringp target
)
1515 (not (string-equal target pgname
))) ;; Move it.
1517 (nnheader-insert-file-contents nnmaildir--file
)
1518 (let ((group-art (gnus-request-accept-article
1519 target nil nil
'no-encode
)))
1520 (when (consp group-art
)
1521 ;; Maybe also copy: dormant forward reply save tick
1522 ;; (gnus-add-mark? gnus-request-set-mark?)
1523 (gnus-group-mark-article-read target
(cdr group-art
)))))
1524 (if (equal target pgname
)
1526 (setq didnt
(cons (nnmaildir--art-num article
) didnt
))
1527 (nnmaildir--unlink nnmaildir--file
)
1528 (nnmaildir--expired-article group article
))))))
1532 (defun nnmaildir-request-set-mark (gname actions
&optional server
)
1533 (let ((group (nnmaildir--prepare server gname
))
1534 (coding-system-for-write nnheader-file-coding-system
)
1535 (buffer-file-coding-system nil
)
1536 (file-coding-system-alist nil
)
1537 del-mark del-action add-action set-action marksdir nlist
1538 ranges begin end article all-marks todo-marks mdir mfile
1539 pgname ls permarkfile deactivate-mark
)
1542 (setq mfile
(nnmaildir--subdir marksdir
(symbol-name mark
))
1543 mfile
(concat mfile
(nnmaildir--art-prefix article
)))
1544 (nnmaildir--unlink mfile
))
1545 del-action
(lambda (article) (mapcar del-mark todo-marks
))
1550 (setq mdir
(nnmaildir--subdir marksdir
(symbol-name mark
))
1551 permarkfile
(concat mdir
":")
1552 mfile
(concat mdir
(nnmaildir--art-prefix article
)))
1553 (nnmaildir--condcase err
(add-name-to-file permarkfile mfile
)
1555 ((nnmaildir--eexist-p err
))
1556 ((nnmaildir--enoent-p err
)
1557 (nnmaildir--mkdir mdir
)
1558 (nnmaildir--mkfile permarkfile
)
1559 (add-name-to-file permarkfile mfile
))
1560 ((nnmaildir--emlink-p err
)
1561 (let ((permarkfilenew (concat permarkfile
"{new}")))
1562 (nnmaildir--mkfile permarkfilenew
)
1563 (rename-file permarkfilenew permarkfile
'replace
)
1564 (add-name-to-file permarkfile mfile
)))
1565 (t (signal (car err
) (cdr err
))))))
1567 set-action
(lambda (article)
1568 (funcall add-action
)
1569 (mapcar (lambda (mark)
1570 (unless (memq mark todo-marks
)
1571 (funcall del-mark mark
)))
1575 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1576 (concat "No such group: " gname
))
1577 (dolist (action actions
)
1578 (setq ranges
(gnus-range-add ranges
(car action
))))
1579 (throw 'return ranges
))
1580 (setq nlist
(nnmaildir--grp-nlist group
)
1581 marksdir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1582 marksdir
(nnmaildir--srvgrp-dir marksdir gname
)
1583 marksdir
(nnmaildir--nndir marksdir
)
1584 marksdir
(nnmaildir--marks-dir marksdir
)
1585 gname
(nnmaildir--grp-name group
)
1586 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1587 ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
)
1588 all-marks
(funcall ls marksdir nil
"\\`[^.]" 'nosort
)
1589 all-marks
(mapcar 'intern all-marks
))
1590 (dolist (action actions
)
1591 (setq ranges
(car action
)
1592 todo-marks
(caddr action
))
1593 (dolist (mark todo-marks
)
1594 (add-to-list 'all-marks mark
))
1595 (if (numberp (cdr ranges
)) (setq ranges
(list ranges
)))
1596 (nnmaildir--nlist-iterate nlist ranges
1597 (cond ((eq 'del
(cadr action
)) del-action
)
1598 ((eq 'add
(cadr action
)) add-action
)
1602 (defun nnmaildir-close-group (gname &optional server
)
1603 (let ((group (nnmaildir--prepare server gname
))
1604 pgname ls dir msgdir files flist dirs
)
1607 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1608 (concat "No such group: " gname
))
1610 (setq pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1611 ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
)
1612 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1613 dir
(nnmaildir--srvgrp-dir dir gname
)
1614 msgdir
(if (nnmaildir--param pgname
'read-only
)
1615 (nnmaildir--new dir
) (nnmaildir--cur dir
))
1616 dir
(nnmaildir--nndir dir
)
1617 dirs
(cons (nnmaildir--nov-dir dir
)
1618 (funcall ls
(nnmaildir--marks-dir dir
) 'full
"\\`[^.]"
1622 (cons dir
(funcall ls dir nil
"\\`[^.]" 'nosort
)))
1624 files
(funcall ls msgdir nil
"\\`[^.]" 'nosort
)
1625 flist
(nnmaildir--up2-1 (length files
))
1626 flist
(make-vector flist
0))
1628 (dolist (file files
)
1629 (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file
)
1630 (intern (match-string 1 file
) flist
)))
1632 (setq files
(cdr dir
)
1633 dir
(file-name-as-directory (car dir
)))
1634 (dolist (file files
)
1635 (unless (or (intern-soft file flist
) (string= file
":"))
1636 (setq file
(concat dir file
))
1637 (delete-file file
))))
1640 (defun nnmaildir-close-server (&optional server
)
1641 (let (flist ls dirs dir files file x
)
1642 (nnmaildir--prepare server nil
)
1643 (when nnmaildir--cur-server
1644 (setq server nnmaildir--cur-server
1645 nnmaildir--cur-server nil
)
1646 (unintern (nnmaildir--srv-address server
) nnmaildir--servers
)))
1649 (defun nnmaildir-request-close ()
1650 (let (servers buffer
)
1651 (mapatoms (lambda (server)
1652 (setq servers
(cons (symbol-name server
) servers
)))
1654 (mapc 'nnmaildir-close-server 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 (provide 'nnmaildir
)
1666 ;; indent-tabs-mode: t
1670 ;; arch-tag: 0c4e44cd-dfde-4040-888e-5597ec771849
1671 ;;; nnmaildir.el ends here