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 3, 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., 51 Franklin Street, Fifth Floor,
21 ;; Boston, MA 02110-1301, USA.
25 ;; Maildir format is documented at <URL:http://cr.yp.to/proto/maildir.html>
26 ;; and in the maildir(5) man page from qmail (available at
27 ;; <URL:http://www.qmail.org/man/man5/maildir.html>). nnmaildir also stores
28 ;; extra information in the .nnmaildir/ directory within a maildir.
30 ;; Some goals of nnmaildir:
31 ;; * Everything Just Works, and correctly. E.g., NOV data is automatically
32 ;; regenerated when stale; no need for manually running
33 ;; *-generate-nov-databases.
34 ;; * Perfect reliability: [C-g] will never corrupt its data in memory, and
35 ;; SIGKILL will never corrupt its data in the filesystem.
36 ;; * Allow concurrent operation as much as possible. If files change out
37 ;; from under us, adapt to the changes or degrade gracefully.
38 ;; * We use the filesystem as a database, so that, e.g., it's easy to
39 ;; manipulate marks from outside Gnus.
40 ;; * All information about a group is stored in the maildir, for easy backup,
41 ;; copying, restoring, etc.
44 ;; * When moving an article for expiry, copy all the marks except 'expire
45 ;; from the original article.
46 ;; * Add a hook for when moving messages from new/ to cur/, to support
47 ;; nnmail's duplicate detection.
48 ;; * Improve generated Xrefs, so crossposts are detectable.
49 ;; * Improve code readability.
53 ;; eval this before editing
55 (put 'nnmaildir--with-nntp-buffer
'lisp-indent-function
0)
56 (put 'nnmaildir--with-work-buffer
'lisp-indent-function
0)
57 (put 'nnmaildir--with-nov-buffer
'lisp-indent-function
0)
58 (put 'nnmaildir--with-move-buffer
'lisp-indent-function
0)
59 (put 'nnmaildir--condcase
'lisp-indent-function
2)
75 (defconst nnmaildir-version
"Gnus")
77 (defvar nnmaildir-article-file-name nil
78 "*The filename of the most recently requested article. This variable is set
79 by nnmaildir-request-article.")
81 ;; The filename of the article being moved/copied:
82 (defvar nnmaildir--file nil
)
84 ;; Variables to generate filenames of messages being delivered:
85 (defvar nnmaildir--delivery-time
"")
86 (defconst nnmaildir--delivery-pid
(concat "P" (number-to-string (emacs-pid))))
87 (defvar nnmaildir--delivery-count nil
)
89 ;; An obarry containing symbols whose names are server names and whose values
91 (defvar nnmaildir--servers
(make-vector 3 0))
92 ;; The current server:
93 (defvar nnmaildir--cur-server nil
)
95 ;; A copy of nnmail-extra-headers
96 (defvar nnmaildir--extra nil
)
98 ;; A NOV structure looks like this (must be prin1-able, so no defstruct):
99 ["subject\tfrom\tdate"
100 "references\tchars\lines"
101 "To: you\tIn-Reply-To: <your.mess@ge>"
102 (12345 67890) ;; modtime of the corresponding article file
103 (to in-reply-to
)] ;; contemporary value of nnmail-extra-headers
104 (defconst nnmaildir--novlen
5)
105 (defmacro nnmaildir--nov-new
(beg mid end mtime extra
)
106 `(vector ,beg
,mid
,end
,mtime
,extra
))
107 (defmacro nnmaildir--nov-get-beg
(nov) `(aref ,nov
0))
108 (defmacro nnmaildir--nov-get-mid
(nov) `(aref ,nov
1))
109 (defmacro nnmaildir--nov-get-end
(nov) `(aref ,nov
2))
110 (defmacro nnmaildir--nov-get-mtime
(nov) `(aref ,nov
3))
111 (defmacro nnmaildir--nov-get-extra
(nov) `(aref ,nov
4))
112 (defmacro nnmaildir--nov-set-beg
(nov value
) `(aset ,nov
0 ,value
))
113 (defmacro nnmaildir--nov-set-mid
(nov value
) `(aset ,nov
1 ,value
))
114 (defmacro nnmaildir--nov-set-end
(nov value
) `(aset ,nov
2 ,value
))
115 (defmacro nnmaildir--nov-set-mtime
(nov value
) `(aset ,nov
3 ,value
))
116 (defmacro nnmaildir--nov-set-extra
(nov value
) `(aset ,nov
4 ,value
))
118 (defstruct nnmaildir--art
119 (prefix nil
:type string
) ;; "time.pid.host"
120 (suffix nil
:type string
) ;; ":2,flags"
121 (num nil
:type natnum
) ;; article number
122 (msgid nil
:type string
) ;; "<mess.age@id>"
123 (nov nil
:type vector
)) ;; cached nov structure, or nil
125 (defstruct nnmaildir--grp
126 (name nil
:type string
) ;; "group.name"
127 (new nil
:type list
) ;; new/ modtime
128 (cur nil
:type list
) ;; cur/ modtime
129 (min 1 :type natnum
) ;; minimum article number
130 (count 0 :type natnum
) ;; count of articles
131 (nlist nil
:type list
) ;; list of articles, ordered descending by number
132 (flist nil
:type vector
) ;; obarray mapping filename prefix->article
133 (mlist nil
:type vector
) ;; obarray mapping message-id->article
134 (cache nil
:type vector
) ;; nov cache
135 (index nil
:type natnum
) ;; index of next cache entry to replace
136 (mmth nil
:type vector
)) ;; obarray mapping mark name->dir modtime
137 ; ("Mark Mod Time Hash")
139 (defstruct nnmaildir--srv
140 (address nil
:type string
) ;; server address string
141 (method nil
:type list
) ;; (nnmaildir "address" ...)
142 (prefix nil
:type string
) ;; "nnmaildir+address:"
143 (dir nil
:type string
) ;; "/expanded/path/to/server/dir/"
144 (ls nil
:type function
) ;; directory-files function
145 (groups nil
:type vector
) ;; obarray mapping group name->group
146 (curgrp nil
:type nnmaildir--grp
) ;; current group, or nil
147 (error nil
:type string
) ;; last error message, or nil
148 (mtime nil
:type list
) ;; modtime of dir
149 (gnm nil
) ;; flag: split from mail-sources?
150 (target-prefix nil
:type string
)) ;; symlink target prefix
152 (defun nnmaildir--expired-article (group article
)
153 (setf (nnmaildir--art-nov article
) nil
)
154 (let ((flist (nnmaildir--grp-flist group
))
155 (mlist (nnmaildir--grp-mlist group
))
156 (min (nnmaildir--grp-min group
))
157 (count (1- (nnmaildir--grp-count group
)))
158 (prefix (nnmaildir--art-prefix article
))
159 (msgid (nnmaildir--art-msgid article
))
161 (nlist-pre '(nil . nil
))
163 (unless (zerop count
)
164 (setq nlist-post
(nnmaildir--grp-nlist group
)
165 num
(nnmaildir--art-num article
))
166 (if (eq num
(caar nlist-post
))
167 (setq new-nlist
(cdr nlist-post
))
168 (setq new-nlist nlist-post
170 nlist-post
(cdr nlist-post
))
171 (while (/= num
(caar nlist-post
))
172 (setq nlist-pre nlist-post
173 nlist-post
(cdr nlist-post
)))
174 (setq nlist-post
(cdr nlist-post
))
176 (setq min
(caar nlist-pre
)))))
177 (let ((inhibit-quit t
))
178 (setf (nnmaildir--grp-min group
) min
)
179 (setf (nnmaildir--grp-count group
) count
)
180 (setf (nnmaildir--grp-nlist group
) new-nlist
)
181 (setcdr nlist-pre nlist-post
)
182 (unintern prefix flist
)
183 (unintern msgid mlist
))))
185 (defun nnmaildir--nlist-art (group num
)
186 (let ((entry (assq num
(nnmaildir--grp-nlist group
))))
189 (defmacro nnmaildir--flist-art
(list file
)
190 `(symbol-value (intern-soft ,file
,list
)))
191 (defmacro nnmaildir--mlist-art
(list msgid
)
192 `(symbol-value (intern-soft ,msgid
,list
)))
194 (defun nnmaildir--pgname (server gname
)
195 (let ((prefix (nnmaildir--srv-prefix server
)))
196 (if prefix
(concat prefix gname
)
197 (setq gname
(gnus-group-prefixed-name gname
198 (nnmaildir--srv-method server
)))
199 (setf (nnmaildir--srv-prefix server
) (gnus-group-real-prefix gname
))
202 (defun nnmaildir--param (pgname param
)
203 (setq param
(gnus-group-find-parameter pgname param
'allow-list
))
204 (if (vectorp param
) (setq param
(aref param
0)))
207 (defmacro nnmaildir--with-nntp-buffer
(&rest body
)
209 (set-buffer nntp-server-buffer
)
211 (defmacro nnmaildir--with-work-buffer
(&rest body
)
213 (set-buffer (get-buffer-create " *nnmaildir work*"))
215 (defmacro nnmaildir--with-nov-buffer
(&rest body
)
217 (set-buffer (get-buffer-create " *nnmaildir nov*"))
219 (defmacro nnmaildir--with-move-buffer
(&rest body
)
221 (set-buffer (get-buffer-create " *nnmaildir move*"))
224 (defmacro nnmaildir--subdir
(dir subdir
)
225 `(file-name-as-directory (concat ,dir
,subdir
)))
226 (defmacro nnmaildir--srvgrp-dir
(srv-dir gname
)
227 `(nnmaildir--subdir ,srv-dir
,gname
))
228 (defmacro nnmaildir--tmp
(dir) `(nnmaildir--subdir ,dir
"tmp"))
229 (defmacro nnmaildir--new
(dir) `(nnmaildir--subdir ,dir
"new"))
230 (defmacro nnmaildir--cur
(dir) `(nnmaildir--subdir ,dir
"cur"))
231 (defmacro nnmaildir--nndir
(dir) `(nnmaildir--subdir ,dir
".nnmaildir"))
232 (defmacro nnmaildir--nov-dir
(dir) `(nnmaildir--subdir ,dir
"nov"))
233 (defmacro nnmaildir--marks-dir
(dir) `(nnmaildir--subdir ,dir
"marks"))
234 (defmacro nnmaildir--num-dir
(dir) `(nnmaildir--subdir ,dir
"num"))
236 (defmacro nnmaildir--unlink
(file-arg)
237 `(let ((file ,file-arg
))
238 (if (file-attributes file
) (delete-file file
))))
239 (defun nnmaildir--mkdir (dir)
240 (or (file-exists-p (file-name-as-directory dir
))
241 (make-directory-internal (directory-file-name dir
))))
242 (defun nnmaildir--mkfile (file)
243 (write-region "" nil file nil
'no-message
))
244 (defun nnmaildir--delete-dir-files (dir ls
)
245 (when (file-attributes dir
)
246 (mapc 'delete-file
(funcall ls dir
'full
"\\`[^.]" 'nosort
))
247 (delete-directory dir
)))
249 (defun nnmaildir--group-maxnum (server group
)
251 (if (zerop (nnmaildir--grp-count group
)) (throw 'return
0))
252 (let ((dir (nnmaildir--srvgrp-dir (nnmaildir--srv-dir server
)
253 (nnmaildir--grp-name group
)))
255 attr ino-opened nlink number-linked
)
256 (setq dir
(nnmaildir--nndir dir
)
257 dir
(nnmaildir--num-dir dir
))
259 (setq attr
(file-attributes
260 (concat dir
(number-to-string number-opened
))))
261 (or attr
(throw 'return
(1- number-opened
)))
262 (setq ino-opened
(nth 10 attr
)
264 number-linked
(+ number-opened nlink
))
265 (if (or (< nlink
1) (< number-linked nlink
))
266 (signal 'error
'("Arithmetic overflow")))
267 (setq attr
(file-attributes
268 (concat dir
(number-to-string number-linked
))))
269 (or attr
(throw 'return
(1- number-linked
)))
270 (if (/= ino-opened
(nth 10 attr
))
271 (setq number-opened number-linked
))))))
273 ;; Make the given server, if non-nil, be the current server. Then make the
274 ;; given group, if non-nil, be the current group of the current server. Then
275 ;; return the group object for the current group.
276 (defun nnmaildir--prepare (server group
)
280 (unless (setq server nnmaildir--cur-server
)
282 (unless (setq server
(intern-soft server nnmaildir--servers
))
284 (setq server
(symbol-value server
)
285 nnmaildir--cur-server server
))
286 (unless (setq groups
(nnmaildir--srv-groups server
))
288 (unless (nnmaildir--srv-method server
)
289 (setq x
(concat "nnmaildir:" (nnmaildir--srv-address server
))
290 x
(gnus-server-to-method x
))
291 (unless x
(throw 'return nil
))
292 (setf (nnmaildir--srv-method server
) x
))
294 (unless (setq group
(nnmaildir--srv-curgrp server
))
296 (unless (setq group
(intern-soft group groups
))
298 (setq group
(symbol-value group
)))
301 (defun nnmaildir--tab-to-space (string)
303 (while (string-match "\t" string pos
)
304 (aset string
(match-beginning 0) ?
)
305 (setq pos
(match-end 0))))
308 (defmacro nnmaildir--condcase
(errsym body
&rest handler
)
309 `(condition-case ,errsym
310 (let ((system-messages-locale "C")) ,body
)
313 (defun nnmaildir--emlink-p (err)
314 (and (eq (car err
) 'file-error
)
315 (string= (downcase (caddr err
)) "too many links")))
317 (defun nnmaildir--enoent-p (err)
318 (and (eq (car err
) 'file-error
)
319 (string= (downcase (caddr err
)) "no such file or directory")))
321 (defun nnmaildir--eexist-p (err)
322 (eq (car err
) 'file-already-exists
))
324 (defun nnmaildir--new-number (nndir)
325 "Allocate a new article number by atomically creating a file under NNDIR."
326 (let ((numdir (nnmaildir--num-dir nndir
))
329 number-link previous-number-link path-open path-link ino-open
)
330 (nnmaildir--mkdir numdir
)
333 (setq path-open
(concat numdir
(number-to-string number-open
)))
334 (if (not make-new-file
)
335 (setq previous-number-link number-link
)
336 (nnmaildir--mkfile path-open
)
337 ;; If Emacs had O_CREAT|O_EXCL, we could return number-open here.
338 (setq make-new-file nil
339 previous-number-link
0))
340 (let* ((attr (file-attributes path-open
))
341 (nlink (nth 1 attr
)))
342 (setq ino-open
(nth 10 attr
)
343 number-link
(+ number-open nlink
))
344 (if (or (< nlink
1) (< number-link nlink
))
345 (signal 'error
'("Arithmetic overflow"))))
346 (if (= number-link previous-number-link
)
347 ;; We've already tried this number, in the previous loop iteration,
349 (signal 'error
`("Corrupt internal nnmaildir data" ,path-open
)))
350 (setq path-link
(concat numdir
(number-to-string number-link
)))
351 (nnmaildir--condcase err
353 (add-name-to-file path-open path-link
)
354 (throw 'return number-link
))
356 ((nnmaildir--emlink-p err
)
357 (setq make-new-file t
358 number-open number-link
))
359 ((nnmaildir--eexist-p err
)
360 (let ((attr (file-attributes path-link
)))
361 (if (/= (nth 10 attr
) ino-open
)
362 (setq number-open number-link
364 (t (signal (car err
) (cdr err
)))))))))
366 (defun nnmaildir--update-nov (server group article
)
367 (let ((nnheader-file-coding-system 'binary
)
368 (srv-dir (nnmaildir--srv-dir server
))
369 (storage-version 1) ;; [version article-number msgid [...nov...]]
370 dir gname pgname msgdir prefix suffix file attr mtime novdir novfile
371 nov msgid nov-beg nov-mid nov-end field val old-extra num numdir
374 (setq gname
(nnmaildir--grp-name group
)
375 pgname
(nnmaildir--pgname server gname
)
376 dir
(nnmaildir--srvgrp-dir srv-dir gname
)
377 msgdir
(if (nnmaildir--param pgname
'read-only
)
378 (nnmaildir--new dir
) (nnmaildir--cur dir
))
379 prefix
(nnmaildir--art-prefix article
)
380 suffix
(nnmaildir--art-suffix article
)
381 file
(concat msgdir prefix suffix
)
382 attr
(file-attributes file
))
384 (nnmaildir--expired-article group article
)
386 (setq mtime
(nth 5 attr
)
388 nov
(nnmaildir--art-nov article
)
389 dir
(nnmaildir--nndir dir
)
390 novdir
(nnmaildir--nov-dir dir
)
391 novfile
(concat novdir prefix
))
392 (unless (equal nnmaildir--extra nnmail-extra-headers
)
393 (setq nnmaildir--extra
(copy-sequence nnmail-extra-headers
)))
394 (nnmaildir--with-nov-buffer
395 ;; First we'll check for already-parsed NOV data.
396 (cond ((not (file-exists-p novfile
))
397 ;; The NOV file doesn't exist; we have to parse the message.
400 ;; The file exists, but the data isn't in memory; read the file.
402 (nnheader-insert-file-contents novfile
)
403 (setq nov
(read (current-buffer)))
404 (if (not (and (vectorp nov
)
406 (equal storage-version
(aref nov
0))))
407 ;; This NOV data seems to be in the wrong format.
409 (unless (nnmaildir--art-num article
)
410 (setf (nnmaildir--art-num article
) (aref nov
1)))
411 (unless (nnmaildir--art-msgid article
)
412 (setf (nnmaildir--art-msgid article
) (aref nov
2)))
413 (setq nov
(aref nov
3)))))
414 ;; Now check whether the already-parsed data (if we have any) is
415 ;; usable: if the message has been edited or if nnmail-extra-headers
416 ;; has been augmented since this data was parsed from the message,
417 ;; then we have to reparse. Otherwise it's up-to-date.
418 (when (and nov
(equal mtime
(nnmaildir--nov-get-mtime nov
)))
419 ;; The timestamp matches. Now check nnmail-extra-headers.
420 (setq old-extra
(nnmaildir--nov-get-extra nov
))
421 (when (equal nnmaildir--extra old-extra
) ;; common case
422 ;; Save memory; use a single copy of the list value.
423 (nnmaildir--nov-set-extra nov nnmaildir--extra
)
425 ;; They're not equal, but maybe the new is a subset of the old.
426 (if (null nnmaildir--extra
)
427 ;; The empty set is a subset of every set.
429 (if (not (memq nil
(mapcar (lambda (e) (memq e old-extra
))
431 (throw 'return nov
)))
432 ;; Parse the NOV data out of the message.
434 (nnheader-insert-file-contents file
)
436 (goto-char (point-min))
438 (if (search-forward "\n\n" nil
'noerror
)
440 (setq nov-mid
(count-lines (point) (point-max)))
441 (narrow-to-region (point-min) (1- (point))))
443 (goto-char (point-min))
445 (setq nov
(nnheader-parse-naked-head)
446 field
(or (mail-header-lines nov
) 0)))
447 (unless (or (zerop field
) (nnmaildir--param pgname
'distrust-Lines
:))
448 (setq nov-mid field
))
449 (setq nov-mid
(number-to-string nov-mid
)
450 nov-mid
(concat (number-to-string attr
) "\t" nov-mid
))
452 (setq field
(or (mail-header-references nov
) ""))
453 (nnmaildir--tab-to-space field
)
454 (setq nov-mid
(concat field
"\t" nov-mid
)
456 (lambda (f) (nnmaildir--tab-to-space (or f
"")))
457 (list (mail-header-subject nov
)
458 (mail-header-from nov
)
459 (mail-header-date nov
)) "\t")
462 (setq field
(symbol-name (car extra
))
464 (nnmaildir--tab-to-space field
)
465 (nnmaildir--tab-to-space val
)
466 (concat field
": " val
))
467 (mail-header-extra nov
) "\t")))
468 (setq msgid
(mail-header-id nov
))
469 (if (or (null msgid
) (nnheader-fake-message-id-p msgid
))
470 (setq msgid
(concat "<" prefix
"@nnmaildir>")))
471 (nnmaildir--tab-to-space msgid
)
472 ;; The data is parsed; create an nnmaildir NOV structure.
473 (setq nov
(nnmaildir--nov-new nov-beg nov-mid nov-end mtime
475 num
(nnmaildir--art-num article
))
477 (setq num
(nnmaildir--new-number dir
))
478 (setf (nnmaildir--art-num article
) num
))
479 ;; Store this new NOV data in a file
481 (prin1 (vector storage-version num msgid nov
) (current-buffer))
482 (setq file
(concat novfile
":"))
483 (nnmaildir--unlink file
)
484 (gmm-write-region (point-min) (point-max) file nil
'no-message nil
486 (rename-file file novfile
'replace
)
487 (setf (nnmaildir--art-msgid article
) msgid
)
490 (defun nnmaildir--cache-nov (group article nov
)
491 (let ((cache (nnmaildir--grp-cache group
))
492 (index (nnmaildir--grp-index group
))
494 (unless (nnmaildir--art-nov article
)
495 (setq goner
(aref cache index
))
496 (if goner
(setf (nnmaildir--art-nov goner
) nil
))
497 (aset cache index article
)
498 (setf (nnmaildir--grp-index group
) (%
(1+ index
) (length cache
))))
499 (setf (nnmaildir--art-nov article
) nov
)))
501 (defun nnmaildir--grp-add-art (server group article
)
502 (let ((nov (nnmaildir--update-nov server group article
))
503 count num min nlist nlist-cdr insert-nlist
)
505 (setq count
(1+ (nnmaildir--grp-count group
))
506 num
(nnmaildir--art-num article
)
507 min
(if (= count
1) num
508 (min num
(nnmaildir--grp-min group
)))
509 nlist
(nnmaildir--grp-nlist group
))
510 (if (or (null nlist
) (> num
(caar nlist
)))
511 (setq nlist
(cons (cons num article
) nlist
))
513 nlist-cdr
(cdr nlist
))
514 (while (and nlist-cdr
(< num
(caar nlist-cdr
)))
515 (setq nlist nlist-cdr
516 nlist-cdr
(cdr nlist
))))
517 (let ((inhibit-quit t
))
518 (setf (nnmaildir--grp-count group
) count
)
519 (setf (nnmaildir--grp-min group
) min
)
521 (setcdr nlist
(cons (cons num article
) nlist-cdr
))
522 (setf (nnmaildir--grp-nlist group
) nlist
))
523 (set (intern (nnmaildir--art-prefix article
)
524 (nnmaildir--grp-flist group
))
526 (set (intern (nnmaildir--art-msgid article
)
527 (nnmaildir--grp-mlist group
))
529 (set (intern (nnmaildir--grp-name group
)
530 (nnmaildir--srv-groups server
))
532 (nnmaildir--cache-nov group article nov
)
535 (defun nnmaildir--group-ls (server pgname
)
536 (or (nnmaildir--param pgname
'directory-files
)
537 (nnmaildir--srv-ls server
)))
539 (defun nnmaildir-article-number-to-file-name
540 (number group-name server-address-string
)
541 (let ((group (nnmaildir--prepare server-address-string group-name
))
545 ;; The given group or server does not exist.
547 (setq article
(nnmaildir--nlist-art group number
))
549 ;; The given article number does not exist in this group.
551 (setq pgname
(nnmaildir--pgname nnmaildir--cur-server group-name
)
552 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
553 dir
(nnmaildir--srvgrp-dir dir group-name
)
554 dir
(if (nnmaildir--param pgname
'read-only
)
555 (nnmaildir--new dir
) (nnmaildir--cur dir
)))
556 (concat dir
(nnmaildir--art-prefix article
)
557 (nnmaildir--art-suffix article
)))))
559 (defun nnmaildir-article-number-to-base-name
560 (number group-name server-address-string
)
561 (let ((x (nnmaildir--prepare server-address-string group-name
)))
563 (setq x
(nnmaildir--nlist-art x number
))
564 (and x
(cons (nnmaildir--art-prefix x
)
565 (nnmaildir--art-suffix x
))))))
567 (defun nnmaildir-base-name-to-article-number
568 (base-name group-name server-address-string
)
569 (let ((x (nnmaildir--prepare server-address-string group-name
)))
571 (setq x
(nnmaildir--grp-flist x
)
572 x
(nnmaildir--flist-art x base-name
))
573 (and x
(nnmaildir--art-num x
)))))
575 (defun nnmaildir--nlist-iterate (nlist ranges func
)
576 (let (entry high low nlist2
)
578 (setq ranges
`((1 .
,(caar nlist
)))))
580 (setq entry
(car ranges
) ranges
(cdr ranges
))
581 (while (and ranges
(eq entry
(car ranges
)))
582 (setq ranges
(cdr ranges
))) ;; skip duplicates
586 (setq low
(car entry
)
588 (setq nlist2 nlist
) ;; Don't assume any sorting of ranges
591 (if (<= (caar nlist2
) high
) (throw 'iterate-loop nil
))
592 (setq nlist2
(cdr nlist2
))))
595 (setq entry
(car nlist2
) nlist2
(cdr nlist2
))
596 (if (< (car entry
) low
) (throw 'iterate-loop nil
))
597 (funcall func
(cdr entry
)))))))
599 (defun nnmaildir--up2-1 (n)
600 (if (zerop n
) 1 (1- (lsh 1 (1+ (logb n
))))))
602 (defun nnmaildir--system-name ()
603 (gnus-replace-in-string
604 (gnus-replace-in-string
605 (gnus-replace-in-string
607 "\\\\" "\\134" 'literal
)
608 "/" "\\057" 'literal
)
609 ":" "\\072" 'literal
))
611 (defun nnmaildir-request-type (group &optional article
)
614 (defun nnmaildir-status-message (&optional server
)
615 (nnmaildir--prepare server nil
)
616 (nnmaildir--srv-error nnmaildir--cur-server
))
618 (defun nnmaildir-server-opened (&optional server
)
619 (and nnmaildir--cur-server
621 (string-equal server
(nnmaildir--srv-address nnmaildir--cur-server
))
623 (nnmaildir--srv-groups nnmaildir--cur-server
)
626 (defun nnmaildir-open-server (server &optional defs
)
630 (setq server
(intern-soft x nnmaildir--servers
))
632 (and (setq server
(symbol-value server
))
633 (nnmaildir--srv-groups server
)
634 (setq nnmaildir--cur-server server
)
636 (setq server
(make-nnmaildir--srv :address x
))
637 (let ((inhibit-quit t
))
638 (set (intern x nnmaildir--servers
) server
)))
639 (setq dir
(assq 'directory defs
))
641 (setf (nnmaildir--srv-error server
)
642 "You must set \"directory\" in the select method")
646 dir
(expand-file-name dir
)
647 dir
(file-name-as-directory dir
))
648 (unless (file-exists-p dir
)
649 (setf (nnmaildir--srv-error server
) (concat "No such directory: " dir
))
651 (setf (nnmaildir--srv-dir server
) dir
)
652 (setq x
(assq 'directory-files defs
))
654 (setq x
(if nnheader-directory-files-is-safe
'directory-files
655 'nnheader-directory-files-safe
))
657 (unless (functionp x
)
658 (setf (nnmaildir--srv-error server
)
659 (concat "Not a function: " (prin1-to-string x
)))
660 (throw 'return nil
)))
661 (setf (nnmaildir--srv-ls server
) x
)
662 (setq size
(length (funcall x dir nil
"\\`[^.]" 'nosort
))
663 size
(nnmaildir--up2-1 size
))
664 (and (setq x
(assq 'get-new-mail defs
))
667 (setf (nnmaildir--srv-gnm server
) t
)
669 (setq x
(assq 'target-prefix defs
))
674 (setf (nnmaildir--srv-target-prefix server
) x
))
675 (setq x
(assq 'create-directory defs
))
680 x
(file-name-as-directory x
))
681 (setf (nnmaildir--srv-target-prefix server
) x
))
682 (setf (nnmaildir--srv-target-prefix server
) "")))
683 (setf (nnmaildir--srv-groups server
) (make-vector size
0))
684 (setq nnmaildir--cur-server server
)
687 (defun nnmaildir--parse-filename (file)
688 (let ((prefix (car file
))
690 (if (string-match "\\`\\([0-9]+\\)\\(\\..*\\)\\'" prefix
)
692 (setq timestamp
(concat "0000" (match-string 1 prefix
))
693 len
(- (length timestamp
) 4))
694 (vector (string-to-number (substring timestamp
0 len
))
695 (string-to-number (substring timestamp len
))
696 (match-string 2 prefix
)
700 (defun nnmaildir--sort-files (a b
)
703 (throw 'return
(and (consp b
) (string-lessp (car a
) (car b
)))))
704 (if (consp b
) (throw 'return t
))
705 (if (< (aref a
0) (aref b
0)) (throw 'return t
))
706 (if (> (aref a
0) (aref b
0)) (throw 'return nil
))
707 (if (< (aref a
1) (aref b
1)) (throw 'return t
))
708 (if (> (aref a
1) (aref b
1)) (throw 'return nil
))
709 (string-lessp (aref a
2) (aref b
2))))
711 (defun nnmaildir--scan (gname scan-msgs groups method srv-dir srv-ls
)
713 (let ((36h-ago (- (car (current-time)) 2))
714 absdir nndir tdir ndir cdir nattr cattr isnew pgname read-only ls
715 files num dir flist group x
)
716 (setq absdir
(nnmaildir--srvgrp-dir srv-dir gname
)
717 nndir
(nnmaildir--nndir absdir
))
718 (unless (file-exists-p absdir
)
719 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
720 (concat "No such directory: " absdir
))
722 (setq tdir
(nnmaildir--tmp absdir
)
723 ndir
(nnmaildir--new absdir
)
724 cdir
(nnmaildir--cur absdir
)
725 nattr
(file-attributes ndir
)
726 cattr
(file-attributes cdir
))
727 (unless (and (file-exists-p tdir
) nattr cattr
)
728 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
729 (concat "Not a maildir: " absdir
))
731 (setq group
(nnmaildir--prepare nil gname
)
732 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
))
736 group
(make-nnmaildir--grp :name gname
:index
0))
737 (nnmaildir--mkdir nndir
)
738 (nnmaildir--mkdir (nnmaildir--nov-dir nndir
))
739 (nnmaildir--mkdir (nnmaildir--marks-dir nndir
)))
740 (setq read-only
(nnmaildir--param pgname
'read-only
)
741 ls
(or (nnmaildir--param pgname
'directory-files
) srv-ls
))
743 (setq x
(nth 11 (file-attributes tdir
)))
744 (unless (and (= x
(nth 11 nattr
)) (= x
(nth 11 cattr
)))
745 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
746 (concat "Maildir spans filesystems: " absdir
))
748 (dolist (file (funcall ls tdir
'full
"\\`[^.]" 'nosort
))
749 (setq x
(file-attributes file
))
750 (if (or (> (cadr x
) 1) (< (car (nth 4 x
)) 36h-ago
))
751 (delete-file file
))))
755 (setq nattr
(nth 5 nattr
))
756 (if (equal nattr
(nnmaildir--grp-new group
))
758 (if read-only
(setq dir
(and (or isnew nattr
) ndir
))
759 (when (or isnew nattr
)
760 (dolist (file (funcall ls ndir nil
"\\`[^.]" 'nosort
))
761 (setq x
(concat ndir file
))
762 (and (time-less-p (nth 5 (file-attributes x
)) (current-time))
763 (rename-file x
(concat cdir file
":2,"))))
764 (setf (nnmaildir--grp-new group
) nattr
))
765 (setq cattr
(nth 5 (file-attributes cdir
)))
766 (if (equal cattr
(nnmaildir--grp-cur group
))
768 (setq dir
(and (or isnew cattr
) cdir
)))
769 (unless dir
(throw 'return t
))
770 (setq files
(funcall ls dir nil
"\\`[^.]" 'nosort
)
771 files
(save-match-data
774 (string-match "\\`\\([^:]*\\)\\(\\(:.*\\)?\\)\\'" f
)
775 (cons (match-string 1 f
) (match-string 2 f
)))
778 (setq num
(nnmaildir--up2-1 (length files
)))
779 (setf (nnmaildir--grp-flist group
) (make-vector num
0))
780 (setf (nnmaildir--grp-mlist group
) (make-vector num
0))
781 (setf (nnmaildir--grp-mmth group
) (make-vector 1 0))
782 (setq num
(nnmaildir--param pgname
'nov-cache-size
))
783 (if (numberp num
) (if (< num
1) (setq num
1))
785 cdir
(nnmaildir--marks-dir nndir
)
786 ndir
(nnmaildir--subdir cdir
"tick")
787 cdir
(nnmaildir--subdir cdir
"read"))
789 (setq file
(car file
))
790 (if (or (not (file-exists-p (concat cdir file
)))
791 (file-exists-p (concat ndir file
)))
792 (setq num
(1+ num
)))))
793 (setf (nnmaildir--grp-cache group
) (make-vector num nil
))
794 (let ((inhibit-quit t
))
795 (set (intern gname groups
) group
))
796 (or scan-msgs
(throw 'return t
)))
797 (setq flist
(nnmaildir--grp-flist group
)
800 (and (null (nnmaildir--flist-art flist
(car file
)))
803 files
(delq nil files
)
804 files
(mapcar 'nnmaildir--parse-filename files
)
805 files
(sort files
'nnmaildir--sort-files
))
807 (setq file
(if (consp file
) file
(aref file
3))
808 x
(make-nnmaildir--art :prefix
(car file
) :suffix
(cdr file
)))
809 (nnmaildir--grp-add-art nnmaildir--cur-server group x
))
810 (if read-only
(setf (nnmaildir--grp-new group
) nattr
)
811 (setf (nnmaildir--grp-cur group
) cattr
)))
814 (defun nnmaildir-request-scan (&optional scan-group server
)
815 (let ((coding-system-for-write nnheader-file-coding-system
)
816 (buffer-file-coding-system nil
)
817 (file-coding-system-alist nil
)
818 (nnmaildir-get-new-mail t
)
819 (nnmaildir-group-alist nil
)
820 (nnmaildir-active-file nil
)
821 x srv-ls srv-dir method groups target-prefix group dirs grp-dir seen
823 (nnmaildir--prepare server nil
)
824 (setq srv-ls
(nnmaildir--srv-ls nnmaildir--cur-server
)
825 srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
826 method
(nnmaildir--srv-method nnmaildir--cur-server
)
827 groups
(nnmaildir--srv-groups nnmaildir--cur-server
)
828 target-prefix
(nnmaildir--srv-target-prefix nnmaildir--cur-server
))
829 (nnmaildir--with-work-buffer
831 (if (stringp scan-group
)
832 (if (nnmaildir--scan scan-group t groups method srv-dir srv-ls
)
833 (if (nnmaildir--srv-gnm nnmaildir--cur-server
)
834 (nnmail-get-new-mail 'nnmaildir nil nil scan-group
))
835 (unintern scan-group groups
))
836 (setq x
(nth 5 (file-attributes srv-dir
))
837 scan-group
(null scan-group
))
838 (if (equal x
(nnmaildir--srv-mtime nnmaildir--cur-server
))
840 (mapatoms (lambda (sym)
841 (nnmaildir--scan (symbol-name sym
) t groups
842 method srv-dir srv-ls
))
844 (setq dirs
(funcall srv-ls srv-dir nil
"\\`[^.]" 'nosort
)
845 dirs
(if (zerop (length target-prefix
))
849 (and (>= (length dir
) (length target-prefix
))
850 (string= (substring dir
0
851 (length target-prefix
))
854 seen
(nnmaildir--up2-1 (length dirs
))
855 seen
(make-vector seen
0))
856 (dolist (grp-dir dirs
)
857 (if (nnmaildir--scan grp-dir scan-group groups method srv-dir
859 (intern grp-dir seen
)))
861 (mapatoms (lambda (group)
862 (setq group
(symbol-name group
))
863 (unless (intern-soft group seen
)
864 (setq x
(cons group x
))))
867 (unintern grp groups
))
868 (setf (nnmaildir--srv-mtime nnmaildir--cur-server
)
869 (nth 5 (file-attributes srv-dir
))))
871 (nnmaildir--srv-gnm nnmaildir--cur-server
)
872 (nnmail-get-new-mail 'nnmaildir nil nil
))))))
875 (defun nnmaildir-request-list (&optional server
)
876 (nnmaildir-request-scan 'find-new-groups server
)
877 (let (pgname ro deactivate-mark
)
878 (nnmaildir--prepare server nil
)
879 (nnmaildir--with-nntp-buffer
881 (mapatoms (lambda (group)
882 (setq pgname
(symbol-name group
)
883 pgname
(nnmaildir--pgname nnmaildir--cur-server pgname
)
884 group
(symbol-value group
)
885 ro
(nnmaildir--param pgname
'read-only
))
886 (insert (nnmaildir--grp-name group
) " ")
887 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group
)
890 (princ (nnmaildir--grp-min group
) nntp-server-buffer
)
891 (insert " " (if ro
"n" "y") "\n"))
892 (nnmaildir--srv-groups nnmaildir--cur-server
))))
895 (defun nnmaildir-request-newgroups (date &optional server
)
896 (nnmaildir-request-list server
))
898 (defun nnmaildir-retrieve-groups (groups &optional server
)
899 (let (group deactivate-mark
)
900 (nnmaildir--prepare server nil
)
901 (nnmaildir--with-nntp-buffer
903 (dolist (gname groups
)
904 (setq group
(nnmaildir--prepare nil gname
))
905 (if (null group
) (insert "411 no such news group\n")
907 (princ (nnmaildir--grp-count group
) nntp-server-buffer
)
909 (princ (nnmaildir--grp-min group
) nntp-server-buffer
)
911 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group
)
913 (insert " " gname
"\n")))))
916 (defun nnmaildir-request-update-info (gname info
&optional server
)
917 (let ((group (nnmaildir--prepare server gname
))
918 pgname flist always-marks never-marks old-marks dotfile num dir
919 markdirs marks mark ranges markdir article read end new-marks ls
920 old-mmth new-mmth mtime mark-sym existing missing deactivate-mark
)
923 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
924 (concat "No such group: " gname
))
926 (setq gname
(nnmaildir--grp-name group
)
927 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
928 flist
(nnmaildir--grp-flist group
))
929 (when (zerop (nnmaildir--grp-count group
))
930 (gnus-info-set-read info nil
)
931 (gnus-info-set-marks info nil
'extend
)
932 (throw 'return info
))
933 (setq old-marks
(cons 'read
(gnus-info-read info
))
934 old-marks
(cons old-marks
(gnus-info-marks info
))
935 always-marks
(nnmaildir--param pgname
'always-marks
)
936 never-marks
(nnmaildir--param pgname
'never-marks
)
937 existing
(nnmaildir--grp-nlist group
)
938 existing
(mapcar 'car existing
)
939 existing
(nreverse existing
)
940 existing
(gnus-compress-sequence existing
'always-list
)
941 missing
(list (cons 1 (nnmaildir--group-maxnum
942 nnmaildir--cur-server group
)))
943 missing
(gnus-range-difference missing existing
)
944 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
945 dir
(nnmaildir--srvgrp-dir dir gname
)
946 dir
(nnmaildir--nndir dir
)
947 dir
(nnmaildir--marks-dir dir
)
948 ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
)
949 markdirs
(funcall ls dir nil
"\\`[^.]" 'nosort
)
950 new-mmth
(nnmaildir--up2-1 (length markdirs
))
951 new-mmth
(make-vector new-mmth
0)
952 old-mmth
(nnmaildir--grp-mmth group
))
953 (dolist (mark markdirs
)
954 (setq markdir
(nnmaildir--subdir dir mark
)
955 mark-sym
(intern mark
)
958 (if (memq mark-sym never-marks
) (throw 'got-ranges nil
))
959 (when (memq mark-sym always-marks
)
960 (setq ranges existing
)
961 (throw 'got-ranges nil
))
962 (setq mtime
(nth 5 (file-attributes markdir
)))
963 (set (intern mark new-mmth
) mtime
)
964 (when (equal mtime
(symbol-value (intern-soft mark old-mmth
)))
965 (setq ranges
(assq mark-sym old-marks
))
966 (if ranges
(setq ranges
(cdr ranges
)))
967 (throw 'got-ranges nil
))
968 (dolist (prefix (funcall ls markdir nil
"\\`[^.]" 'nosort
))
969 (setq article
(nnmaildir--flist-art flist prefix
))
972 (gnus-add-to-range ranges
973 `(,(nnmaildir--art-num article
)))))))
974 (if (eq mark-sym
'read
) (setq read ranges
)
975 (if ranges
(setq marks
(cons (cons mark-sym ranges
) marks
)))))
976 (gnus-info-set-read info
(gnus-range-add read missing
))
977 (gnus-info-set-marks info marks
'extend
)
978 (setf (nnmaildir--grp-mmth group
) new-mmth
)
981 (defun nnmaildir-request-group (gname &optional server fast
)
982 (let ((group (nnmaildir--prepare server gname
))
986 ;; (insert "411 no such news group\n")
987 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
988 (concat "No such group: " gname
))
990 (setf (nnmaildir--srv-curgrp nnmaildir--cur-server
) group
)
991 (if fast
(throw 'return t
))
992 (nnmaildir--with-nntp-buffer
995 (princ (nnmaildir--grp-count group
) nntp-server-buffer
)
997 (princ (nnmaildir--grp-min group
) nntp-server-buffer
)
999 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group
)
1001 (insert " " gname
"\n")
1004 (defun nnmaildir-request-create-group (gname &optional server args
)
1005 (nnmaildir--prepare server nil
)
1007 (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server
))
1009 (when (zerop (length gname
))
1010 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1011 "Invalid (empty) group name")
1012 (throw 'return nil
))
1013 (when (eq (aref "." 0) (aref gname
0))
1014 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1015 "Group names may not start with \".\"")
1016 (throw 'return nil
))
1017 (when (save-match-data (string-match "[\0/\t]" gname
))
1018 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1019 (concat "Invalid characters (null, tab, or /) in group name: "
1021 (throw 'return nil
))
1022 (setq groups
(nnmaildir--srv-groups nnmaildir--cur-server
))
1023 (when (intern-soft gname groups
)
1024 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1025 (concat "Group already exists: " gname
))
1026 (throw 'return nil
))
1027 (setq srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
))
1028 (if (file-name-absolute-p target-prefix
)
1029 (setq dir
(expand-file-name target-prefix
))
1031 dir
(file-truename dir
)
1032 dir
(concat dir target-prefix
)))
1033 (setq dir
(nnmaildir--subdir dir gname
))
1034 (nnmaildir--mkdir dir
)
1035 (nnmaildir--mkdir (nnmaildir--tmp dir
))
1036 (nnmaildir--mkdir (nnmaildir--new dir
))
1037 (nnmaildir--mkdir (nnmaildir--cur dir
))
1038 (unless (string= target-prefix
"")
1039 (make-symbolic-link (concat target-prefix gname
)
1040 (concat srv-dir gname
)))
1041 (nnmaildir-request-scan 'find-new-groups
))))
1043 (defun nnmaildir-request-rename-group (gname new-name
&optional server
)
1044 (let ((group (nnmaildir--prepare server gname
))
1045 (coding-system-for-write nnheader-file-coding-system
)
1046 (buffer-file-coding-system nil
)
1047 (file-coding-system-alist nil
)
1051 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1052 (concat "No such group: " gname
))
1053 (throw 'return nil
))
1054 (when (zerop (length new-name
))
1055 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1056 "Invalid (empty) group name")
1057 (throw 'return nil
))
1058 (when (eq (aref "." 0) (aref new-name
0))
1059 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1060 "Group names may not start with \".\"")
1061 (throw 'return nil
))
1062 (when (save-match-data (string-match "[\0/\t]" new-name
))
1063 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1064 (concat "Invalid characters (null, tab, or /) in group name: "
1066 (throw 'return nil
))
1067 (if (string-equal gname new-name
) (throw 'return t
))
1068 (when (intern-soft new-name
1069 (nnmaildir--srv-groups nnmaildir--cur-server
))
1070 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1071 (concat "Group already exists: " new-name
))
1072 (throw 'return nil
))
1073 (setq srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
))
1075 (rename-file (concat srv-dir gname
)
1076 (concat srv-dir new-name
))
1078 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1079 (concat "Error renaming link: " (prin1-to-string err
)))
1080 (throw 'return nil
)))
1081 (setq x
(nnmaildir--srv-groups nnmaildir--cur-server
)
1082 groups
(make-vector (length x
) 0))
1083 (mapatoms (lambda (sym)
1084 (unless (eq (symbol-value sym
) group
)
1085 (set (intern (symbol-name sym
) groups
)
1086 (symbol-value sym
))))
1088 (setq group
(copy-sequence group
))
1089 (setf (nnmaildir--grp-name group
) new-name
)
1090 (set (intern new-name groups
) group
)
1091 (setf (nnmaildir--srv-groups nnmaildir--cur-server
) groups
)
1094 (defun nnmaildir-request-delete-group (gname force
&optional server
)
1095 (let ((group (nnmaildir--prepare server gname
))
1096 pgname grp-dir target dir ls deactivate-mark
)
1099 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1100 (concat "No such group: " gname
))
1101 (throw 'return nil
))
1102 (setq gname
(nnmaildir--grp-name group
)
1103 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1104 grp-dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1105 target
(car (file-attributes (concat grp-dir gname
)))
1106 grp-dir
(nnmaildir--srvgrp-dir grp-dir gname
))
1107 (unless (or force
(stringp target
))
1108 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1109 (concat "Not a symlink: " gname
))
1110 (throw 'return nil
))
1111 (if (eq group
(nnmaildir--srv-curgrp nnmaildir--cur-server
))
1112 (setf (nnmaildir--srv-curgrp nnmaildir--cur-server
) nil
))
1113 (unintern gname
(nnmaildir--srv-groups nnmaildir--cur-server
))
1116 (setq grp-dir
(directory-file-name grp-dir
))
1117 (nnmaildir--unlink grp-dir
))
1118 (setq ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
))
1119 (if (nnmaildir--param pgname
'read-only
)
1120 (progn (delete-directory (nnmaildir--tmp grp-dir
))
1121 (nnmaildir--unlink (nnmaildir--new grp-dir
))
1122 (delete-directory (nnmaildir--cur grp-dir
)))
1123 (nnmaildir--delete-dir-files (nnmaildir--tmp grp-dir
) ls
)
1124 (nnmaildir--delete-dir-files (nnmaildir--new grp-dir
) ls
)
1125 (nnmaildir--delete-dir-files (nnmaildir--cur grp-dir
) ls
))
1126 (setq dir
(nnmaildir--nndir grp-dir
))
1127 (dolist (subdir `(,(nnmaildir--nov-dir dir
) ,(nnmaildir--num-dir dir
)
1128 ,@(funcall ls
(nnmaildir--marks-dir dir
)
1129 'full
"\\`[^.]" 'nosort
)))
1130 (nnmaildir--delete-dir-files subdir ls
))
1131 (setq dir
(nnmaildir--nndir grp-dir
))
1132 (nnmaildir--unlink (concat dir
"markfile"))
1133 (nnmaildir--unlink (concat dir
"markfile{new}"))
1134 (delete-directory (nnmaildir--marks-dir dir
))
1135 (delete-directory dir
)
1136 (if (not (stringp target
))
1137 (delete-directory grp-dir
)
1138 (setq grp-dir
(directory-file-name grp-dir
)
1140 (unless (eq (aref "/" 0) (aref dir
0))
1141 (setq dir
(concat (file-truename
1142 (nnmaildir--srv-dir nnmaildir--cur-server
))
1144 (delete-directory dir
)
1145 (nnmaildir--unlink grp-dir
)))
1148 (defun nnmaildir-retrieve-headers (articles &optional gname server fetch-old
)
1149 (let ((group (nnmaildir--prepare server gname
))
1150 srv-dir dir nlist mlist article num start stop nov nlist2 insert-nov
1154 (setq nov
(nnmaildir--update-nov nnmaildir--cur-server group
1157 (nnmaildir--cache-nov group article nov
)
1158 (setq num
(nnmaildir--art-num article
))
1159 (princ num nntp-server-buffer
)
1160 (insert "\t" (nnmaildir--nov-get-beg nov
) "\t"
1161 (nnmaildir--art-msgid article
) "\t"
1162 (nnmaildir--nov-get-mid nov
) "\tXref: nnmaildir "
1164 (princ num nntp-server-buffer
)
1165 (insert "\t" (nnmaildir--nov-get-end nov
) "\n"))))
1168 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1169 (if gname
(concat "No such group: " gname
) "No current group"))
1170 (throw 'return nil
))
1171 (nnmaildir--with-nntp-buffer
1173 (setq mlist
(nnmaildir--grp-mlist group
)
1174 nlist
(nnmaildir--grp-nlist group
)
1175 gname
(nnmaildir--grp-name group
)
1176 srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1177 dir
(nnmaildir--srvgrp-dir srv-dir gname
))
1180 ((and fetch-old
(not (numberp fetch-old
)))
1181 (nnmaildir--nlist-iterate nlist
'all insert-nov
))
1183 ((stringp (car articles
))
1184 (dolist (msgid articles
)
1185 (setq article
(nnmaildir--mlist-art mlist msgid
))
1186 (if article
(funcall insert-nov article
))))
1189 ;; Assume the article range list is sorted ascending
1190 (setq stop
(car articles
)
1191 start
(car (last articles
))
1192 stop
(if (numberp stop
) stop
(car stop
))
1193 start
(if (numberp start
) start
(cdr start
))
1194 stop
(- stop fetch-old
)
1195 stop
(if (< stop
1) 1 stop
)
1196 articles
(list (cons stop start
))))
1197 (nnmaildir--nlist-iterate nlist articles insert-nov
)))
1198 (sort-numeric-fields 1 (point-min) (point-max))
1201 (defun nnmaildir-request-article (num-msgid &optional gname server to-buffer
)
1202 (let ((group (nnmaildir--prepare server gname
))
1203 (case-fold-search t
)
1204 list article dir pgname deactivate-mark
)
1207 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1208 (if gname
(concat "No such group: " gname
) "No current group"))
1209 (throw 'return nil
))
1210 (if (numberp num-msgid
)
1211 (setq article
(nnmaildir--nlist-art group num-msgid
))
1212 (setq list
(nnmaildir--grp-mlist group
)
1213 article
(nnmaildir--mlist-art list num-msgid
))
1214 (if article
(setq num-msgid
(nnmaildir--art-num article
))
1218 (setq group
(symbol-value group-sym
)
1219 list
(nnmaildir--grp-mlist group
)
1220 article
(nnmaildir--mlist-art list num-msgid
))
1222 (setq num-msgid
(nnmaildir--art-num article
))
1223 (throw 'found nil
)))
1224 (nnmaildir--srv-groups nnmaildir--cur-server
))))
1226 (setf (nnmaildir--srv-error nnmaildir--cur-server
) "No such article")
1227 (throw 'return nil
)))
1228 (setq gname
(nnmaildir--grp-name group
)
1229 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1230 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1231 dir
(nnmaildir--srvgrp-dir dir gname
)
1232 dir
(if (nnmaildir--param pgname
'read-only
)
1233 (nnmaildir--new dir
) (nnmaildir--cur dir
))
1234 nnmaildir-article-file-name
1236 (nnmaildir--art-prefix article
)
1237 (nnmaildir--art-suffix article
)))
1238 (unless (file-exists-p nnmaildir-article-file-name
)
1239 (nnmaildir--expired-article group article
)
1240 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1241 "Article has expired")
1242 (throw 'return nil
))
1244 (set-buffer (or to-buffer nntp-server-buffer
))
1246 (nnheader-insert-file-contents nnmaildir-article-file-name
))
1247 (cons gname num-msgid
))))
1249 (defun nnmaildir-request-post (&optional server
)
1250 (let (message-required-mail-headers)
1251 (funcall message-send-mail-function
)))
1253 (defun nnmaildir-request-replace-article (number gname buffer
)
1254 (let ((group (nnmaildir--prepare nil gname
))
1255 (coding-system-for-write nnheader-file-coding-system
)
1256 (buffer-file-coding-system nil
)
1257 (file-coding-system-alist nil
)
1258 dir file article suffix tmpfile deactivate-mark
)
1261 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1262 (concat "No such group: " gname
))
1263 (throw 'return nil
))
1264 (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname
)
1266 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1267 (concat "Read-only group: " group
))
1268 (throw 'return nil
))
1269 (setq dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1270 dir
(nnmaildir--srvgrp-dir dir gname
)
1271 article
(nnmaildir--nlist-art group number
))
1273 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1274 (concat "No such article: " (number-to-string number
)))
1275 (throw 'return nil
))
1276 (setq suffix
(nnmaildir--art-suffix article
)
1277 file
(nnmaildir--art-prefix article
)
1278 tmpfile
(concat (nnmaildir--tmp dir
) file
))
1279 (when (file-exists-p tmpfile
)
1280 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1281 (concat "File exists: " tmpfile
))
1282 (throw 'return nil
))
1285 (gmm-write-region (point-min) (point-max) tmpfile nil
'no-message nil
1287 (unix-sync) ;; no fsync :(
1288 (rename-file tmpfile
(concat (nnmaildir--cur dir
) file suffix
) 'replace
)
1291 (defun nnmaildir-request-move-article (article gname server accept-form
1292 &optional last move-is-internal
)
1293 (let ((group (nnmaildir--prepare server gname
))
1294 pgname suffix result nnmaildir--file deactivate-mark
)
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 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1302 article
(nnmaildir--nlist-art group article
))
1304 (setf (nnmaildir--srv-error nnmaildir--cur-server
) "No such article")
1305 (throw 'return nil
))
1306 (setq suffix
(nnmaildir--art-suffix article
)
1307 nnmaildir--file
(nnmaildir--srv-dir nnmaildir--cur-server
)
1308 nnmaildir--file
(nnmaildir--srvgrp-dir nnmaildir--file gname
)
1309 nnmaildir--file
(if (nnmaildir--param pgname
'read-only
)
1310 (nnmaildir--new nnmaildir--file
)
1311 (nnmaildir--cur nnmaildir--file
))
1312 nnmaildir--file
(concat nnmaildir--file
1313 (nnmaildir--art-prefix article
)
1315 (unless (file-exists-p nnmaildir--file
)
1316 (nnmaildir--expired-article group article
)
1317 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1318 "Article has expired")
1319 (throw 'return nil
))
1320 (nnmaildir--with-move-buffer
1322 (nnheader-insert-file-contents nnmaildir--file
)
1323 (setq result
(eval accept-form
)))
1324 (unless (or (null result
) (nnmaildir--param pgname
'read-only
))
1325 (nnmaildir--unlink nnmaildir--file
)
1326 (nnmaildir--expired-article group article
))
1329 (defun nnmaildir-request-accept-article (gname &optional server last
)
1330 (let ((group (nnmaildir--prepare server gname
))
1331 (coding-system-for-write nnheader-file-coding-system
)
1332 (buffer-file-coding-system nil
)
1333 (file-coding-system-alist nil
)
1334 srv-dir dir file time tmpfile curfile
24h article
)
1337 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1338 (concat "No such group: " gname
))
1339 (throw 'return nil
))
1340 (setq gname
(nnmaildir--grp-name group
))
1341 (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname
)
1343 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1344 (concat "Read-only group: " gname
))
1345 (throw 'return nil
))
1346 (setq srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1347 dir
(nnmaildir--srvgrp-dir srv-dir gname
)
1349 file
(format-time-string "%s." time
))
1350 (unless (string-equal nnmaildir--delivery-time file
)
1351 (setq nnmaildir--delivery-time file
1352 nnmaildir--delivery-count
0))
1353 (when (and (consp (cdr time
))
1354 (consp (cddr time
)))
1355 (setq file
(concat file
"M" (number-to-string (caddr time
)))))
1356 (setq file
(concat file nnmaildir--delivery-pid
)
1357 file
(concat file
"Q" (number-to-string nnmaildir--delivery-count
))
1358 file
(concat file
"." (nnmaildir--system-name))
1359 tmpfile
(concat (nnmaildir--tmp dir
) file
)
1360 curfile
(concat (nnmaildir--cur dir
) file
":2,"))
1361 (when (file-exists-p tmpfile
)
1362 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1363 (concat "File exists: " tmpfile
))
1364 (throw 'return nil
))
1365 (when (file-exists-p curfile
)
1366 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1367 (concat "File exists: " curfile
))
1368 (throw 'return nil
))
1369 (setq nnmaildir--delivery-count
(1+ nnmaildir--delivery-count
)
1370 24h
(run-with-timer 86400 nil
1372 (nnmaildir--unlink tmpfile
)
1373 (setf (nnmaildir--srv-error
1374 nnmaildir--cur-server
)
1375 "24-hour timer expired")
1376 (throw 'return nil
))))
1377 (condition-case nil
(add-name-to-file nnmaildir--file tmpfile
)
1379 (gmm-write-region (point-min) (point-max) tmpfile nil
'no-message nil
1381 (unix-sync))) ;; no fsync :(
1382 (nnheader-cancel-timer 24h
)
1384 (add-name-to-file tmpfile curfile
)
1386 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1387 (concat "Error linking: " (prin1-to-string err
)))
1388 (nnmaildir--unlink tmpfile
)
1389 (throw 'return nil
)))
1390 (nnmaildir--unlink tmpfile
)
1391 (setq article
(make-nnmaildir--art :prefix file
:suffix
":2,"))
1392 (if (nnmaildir--grp-add-art nnmaildir--cur-server group article
)
1393 (cons gname
(nnmaildir--art-num article
))))))
1395 (defun nnmaildir-save-mail (group-art)
1398 (throw 'return nil
))
1399 (let (ga gname x groups nnmaildir--file deactivate-mark
)
1401 (goto-char (point-min))
1403 (while (looking-at "From ")
1404 (replace-match "X-From-Line: ")
1406 (setq groups
(nnmaildir--srv-groups nnmaildir--cur-server
)
1407 ga
(car group-art
) group-art
(cdr group-art
)
1409 (or (intern-soft gname groups
)
1410 (nnmaildir-request-create-group gname
)
1411 (throw 'return nil
)) ;; not that nnmail bothers to check :(
1412 (unless (nnmaildir-request-accept-article gname
)
1413 (throw 'return nil
))
1414 (setq nnmaildir--file
(nnmaildir--srv-dir nnmaildir--cur-server
)
1415 nnmaildir--file
(nnmaildir--srvgrp-dir nnmaildir--file gname
)
1416 x
(nnmaildir--prepare nil gname
)
1417 x
(nnmaildir--grp-nlist x
)
1419 nnmaildir--file
(concat nnmaildir--file
1420 (nnmaildir--art-prefix x
)
1421 (nnmaildir--art-suffix x
)))
1425 (setq gname
(car ga
))
1426 (and (or (intern-soft gname groups
)
1427 (nnmaildir-request-create-group gname
))
1428 (nnmaildir-request-accept-article gname
)
1432 (defun nnmaildir-active-number (gname)
1435 (defun nnmaildir-request-expire-articles (ranges &optional gname server force
)
1436 (let ((no-force (not force
))
1437 (group (nnmaildir--prepare server gname
))
1438 pgname time boundary bound-iter high low target dir nlist nlist2
1439 stop article didnt nnmaildir--file nnmaildir-article-file-name
1443 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1444 (if gname
(concat "No such group: " gname
) "No current group"))
1445 (throw 'return
(gnus-uncompress-range ranges
)))
1446 (setq gname
(nnmaildir--grp-name group
)
1447 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
))
1448 (if (nnmaildir--param pgname
'read-only
)
1449 (throw 'return
(gnus-uncompress-range ranges
)))
1450 (setq time
(nnmaildir--param pgname
'expire-age
))
1452 (setq time
(or (and nnmail-expiry-wait-function
1453 (funcall nnmail-expiry-wait-function gname
))
1454 nnmail-expiry-wait
))
1455 (if (eq time
'immediate
)
1458 (setq time
(* time
86400)))))
1460 (unless (integerp time
) ;; handle 'never
1461 (throw 'return
(gnus-uncompress-range ranges
)))
1462 (setq boundary
(current-time)
1463 high
(- (car boundary
) (/ time
65536))
1464 low
(- (cadr boundary
) (% time
65536)))
1466 (setq low
(+ low
65536)
1468 (setcar (cdr boundary
) low
)
1469 (setcar boundary high
))
1470 (setq dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1471 dir
(nnmaildir--srvgrp-dir dir gname
)
1472 dir
(nnmaildir--cur dir
)
1473 nlist
(nnmaildir--grp-nlist group
)
1474 ranges
(reverse ranges
))
1475 (nnmaildir--with-move-buffer
1476 (nnmaildir--nlist-iterate
1479 (setq nnmaildir--file
(nnmaildir--art-prefix article
)
1480 nnmaildir--file
(concat dir nnmaildir--file
1481 (nnmaildir--art-suffix article
))
1482 time
(file-attributes nnmaildir--file
))
1485 (nnmaildir--expired-article group article
))
1488 (setq time
(nth 5 time
)
1489 bound-iter boundary
)
1490 (while (and bound-iter time
1491 (= (car bound-iter
) (car time
)))
1492 (setq bound-iter
(cdr bound-iter
)
1494 (and bound-iter time
1495 (car-less-than-car bound-iter time
))))
1496 (setq didnt
(cons (nnmaildir--art-num article
) didnt
)))
1498 (setq nnmaildir-article-file-name nnmaildir--file
1499 target
(if force nil
1502 (nnmaildir--param pgname
'expire-group
)))))
1503 (when (and (stringp target
)
1504 (not (string-equal target pgname
))) ;; Move it.
1506 (nnheader-insert-file-contents nnmaildir--file
)
1507 (let ((group-art (gnus-request-accept-article
1508 target nil nil
'no-encode
)))
1509 (when (consp group-art
)
1510 ;; Maybe also copy: dormant forward reply save tick
1511 ;; (gnus-add-mark? gnus-request-set-mark?)
1512 (gnus-group-mark-article-read target
(cdr group-art
)))))
1513 (if (equal target pgname
)
1515 (setq didnt
(cons (nnmaildir--art-num article
) didnt
))
1516 (nnmaildir--unlink nnmaildir--file
)
1517 (nnmaildir--expired-article group article
))))))
1521 (defun nnmaildir-request-set-mark (gname actions
&optional server
)
1522 (let ((group (nnmaildir--prepare server gname
))
1523 (coding-system-for-write nnheader-file-coding-system
)
1524 (buffer-file-coding-system nil
)
1525 (file-coding-system-alist nil
)
1526 del-mark del-action add-action set-action marksdir nlist
1527 ranges begin end article all-marks todo-marks mdir mfile
1528 pgname ls permarkfile deactivate-mark
)
1531 (setq mfile
(nnmaildir--subdir marksdir
(symbol-name mark
))
1532 mfile
(concat mfile
(nnmaildir--art-prefix article
)))
1533 (nnmaildir--unlink mfile
))
1534 del-action
(lambda (article) (mapcar del-mark todo-marks
))
1539 (setq mdir
(nnmaildir--subdir marksdir
(symbol-name mark
))
1540 permarkfile
(concat mdir
":")
1541 mfile
(concat mdir
(nnmaildir--art-prefix article
)))
1542 (nnmaildir--condcase err
(add-name-to-file permarkfile mfile
)
1544 ((nnmaildir--eexist-p err
))
1545 ((nnmaildir--enoent-p err
)
1546 (nnmaildir--mkdir mdir
)
1547 (nnmaildir--mkfile permarkfile
)
1548 (add-name-to-file permarkfile mfile
))
1549 ((nnmaildir--emlink-p err
)
1550 (let ((permarkfilenew (concat permarkfile
"{new}")))
1551 (nnmaildir--mkfile permarkfilenew
)
1552 (rename-file permarkfilenew permarkfile
'replace
)
1553 (add-name-to-file permarkfile mfile
)))
1554 (t (signal (car err
) (cdr err
))))))
1556 set-action
(lambda (article)
1557 (funcall add-action
)
1558 (mapcar (lambda (mark)
1559 (unless (memq mark todo-marks
)
1560 (funcall del-mark mark
)))
1564 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1565 (concat "No such group: " gname
))
1566 (dolist (action actions
)
1567 (setq ranges
(gnus-range-add ranges
(car action
))))
1568 (throw 'return ranges
))
1569 (setq nlist
(nnmaildir--grp-nlist group
)
1570 marksdir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1571 marksdir
(nnmaildir--srvgrp-dir marksdir gname
)
1572 marksdir
(nnmaildir--nndir marksdir
)
1573 marksdir
(nnmaildir--marks-dir marksdir
)
1574 gname
(nnmaildir--grp-name group
)
1575 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1576 ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
)
1577 all-marks
(funcall ls marksdir nil
"\\`[^.]" 'nosort
)
1578 all-marks
(mapcar 'intern all-marks
))
1579 (dolist (action actions
)
1580 (setq ranges
(car action
)
1581 todo-marks
(caddr action
))
1582 (dolist (mark todo-marks
)
1583 (add-to-list 'all-marks mark
))
1584 (if (numberp (cdr ranges
)) (setq ranges
(list ranges
)))
1585 (nnmaildir--nlist-iterate nlist ranges
1586 (cond ((eq 'del
(cadr action
)) del-action
)
1587 ((eq 'add
(cadr action
)) add-action
)
1591 (defun nnmaildir-close-group (gname &optional server
)
1592 (let ((group (nnmaildir--prepare server gname
))
1593 pgname ls dir msgdir files flist dirs
)
1596 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1597 (concat "No such group: " gname
))
1599 (setq pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1600 ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
)
1601 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1602 dir
(nnmaildir--srvgrp-dir dir gname
)
1603 msgdir
(if (nnmaildir--param pgname
'read-only
)
1604 (nnmaildir--new dir
) (nnmaildir--cur dir
))
1605 dir
(nnmaildir--nndir dir
)
1606 dirs
(cons (nnmaildir--nov-dir dir
)
1607 (funcall ls
(nnmaildir--marks-dir dir
) 'full
"\\`[^.]"
1611 (cons dir
(funcall ls dir nil
"\\`[^.]" 'nosort
)))
1613 files
(funcall ls msgdir nil
"\\`[^.]" 'nosort
)
1614 flist
(nnmaildir--up2-1 (length files
))
1615 flist
(make-vector flist
0))
1617 (dolist (file files
)
1618 (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file
)
1619 (intern (match-string 1 file
) flist
)))
1621 (setq files
(cdr dir
)
1622 dir
(file-name-as-directory (car dir
)))
1623 (dolist (file files
)
1624 (unless (or (intern-soft file flist
) (string= file
":"))
1625 (setq file
(concat dir file
))
1626 (delete-file file
))))
1629 (defun nnmaildir-close-server (&optional server
)
1630 (let (flist ls dirs dir files file x
)
1631 (nnmaildir--prepare server nil
)
1632 (when nnmaildir--cur-server
1633 (setq server nnmaildir--cur-server
1634 nnmaildir--cur-server nil
)
1635 (unintern (nnmaildir--srv-address server
) nnmaildir--servers
)))
1638 (defun nnmaildir-request-close ()
1639 (let (servers buffer
)
1640 (mapatoms (lambda (server)
1641 (setq servers
(cons (symbol-name server
) servers
)))
1643 (mapc 'nnmaildir-close-server servers
)
1644 (setq buffer
(get-buffer " *nnmaildir work*"))
1645 (if buffer
(kill-buffer buffer
))
1646 (setq buffer
(get-buffer " *nnmaildir nov*"))
1647 (if buffer
(kill-buffer buffer
))
1648 (setq buffer
(get-buffer " *nnmaildir move*"))
1649 (if buffer
(kill-buffer buffer
)))
1652 (provide 'nnmaildir
)
1655 ;; indent-tabs-mode: t
1659 ;;; arch-tag: 0c4e44cd-dfde-4040-888e-5597ec771849
1660 ;;; nnmaildir.el ends here