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 <https://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)
74 (defconst nnmaildir-version
"Gnus")
76 (defconst nnmaildir-flag-mark-mapping
81 "Alist mapping Maildir filename flags to Gnus marks.
82 Maildir filenames are of the form \"unique-id:2,FLAGS\",
83 where FLAGS are a string of characters in ASCII order.
84 Some of the FLAGS correspond to Gnus marks.")
86 (defsubst nnmaildir--mark-to-flag
(mark)
87 "Find the Maildir flag that corresponds to MARK (an atom).
88 Return a character, or nil if not found.
89 See `nnmaildir-flag-mark-mapping'."
90 (car (rassq mark nnmaildir-flag-mark-mapping
)))
92 (defsubst nnmaildir--flag-to-mark
(flag)
93 "Find the Gnus mark that corresponds to FLAG (a character).
94 Return an atom, or nil if not found.
95 See `nnmaildir-flag-mark-mapping'."
96 (cdr (assq flag nnmaildir-flag-mark-mapping
)))
98 (defun nnmaildir--ensure-suffix (filename)
99 "Ensure that FILENAME contains the suffix \":2,\"."
100 (if (string-match-p ":2," filename
)
102 (concat filename
":2,")))
104 (defun nnmaildir--add-flag (flag suffix
)
105 "Return a copy of SUFFIX where FLAG is set.
106 SUFFIX should start with \":2,\"."
107 (unless (string-match-p "^:2," suffix
)
108 (error "Invalid suffix `%s'" suffix
))
109 (let* ((flags (substring suffix
3))
110 (flags-as-list (append flags nil
))
112 (concat (gnus-delete-duplicates
113 ;; maildir flags must be sorted
114 (sort (cons flag flags-as-list
) '<)))))
115 (concat ":2," new-flags
)))
117 (defun nnmaildir--remove-flag (flag suffix
)
118 "Return a copy of SUFFIX where FLAG is cleared.
119 SUFFIX should start with \":2,\"."
120 (unless (string-match-p "^:2," suffix
)
121 (error "Invalid suffix `%s'" suffix
))
122 (let* ((flags (substring suffix
3))
123 (flags-as-list (append flags nil
))
124 (new-flags (concat (delq flag flags-as-list
))))
125 (concat ":2," new-flags
)))
127 (defvar nnmaildir-article-file-name nil
128 "The filename of the most recently requested article.
129 This variable is set by `nnmaildir-request-article'.")
131 ;; The filename of the article being moved/copied:
132 (defvar nnmaildir--file nil
)
134 ;; Variables to generate filenames of messages being delivered:
135 (defvar nnmaildir--delivery-time
"")
136 (defconst nnmaildir--delivery-pid
(concat "P" (number-to-string (emacs-pid))))
137 (defvar nnmaildir--delivery-count nil
)
139 ;; An obarry containing symbols whose names are server names and whose values
141 (defvar nnmaildir--servers
(make-vector 3 0))
142 ;; The current server:
143 (defvar nnmaildir--cur-server nil
)
145 ;; A copy of nnmail-extra-headers
146 (defvar nnmaildir--extra nil
)
148 ;; A NOV structure looks like this (must be prin1-able, so no defstruct):
149 ["subject\tfrom\tdate"
150 "references\tchars\tlines"
151 "To: you\tIn-Reply-To: <your.mess@ge>"
152 (12345 67890) ;; modtime of the corresponding article file
153 (to in-reply-to
)] ;; contemporary value of nnmail-extra-headers
154 (defconst nnmaildir--novlen
5)
155 (defmacro nnmaildir--nov-new
(beg mid end mtime extra
)
156 `(vector ,beg
,mid
,end
,mtime
,extra
))
157 (defmacro nnmaildir--nov-get-beg
(nov) `(aref ,nov
0))
158 (defmacro nnmaildir--nov-get-mid
(nov) `(aref ,nov
1))
159 (defmacro nnmaildir--nov-get-end
(nov) `(aref ,nov
2))
160 (defmacro nnmaildir--nov-get-mtime
(nov) `(aref ,nov
3))
161 (defmacro nnmaildir--nov-get-extra
(nov) `(aref ,nov
4))
162 (defmacro nnmaildir--nov-set-beg
(nov value
) `(aset ,nov
0 ,value
))
163 (defmacro nnmaildir--nov-set-mid
(nov value
) `(aset ,nov
1 ,value
))
164 (defmacro nnmaildir--nov-set-end
(nov value
) `(aset ,nov
2 ,value
))
165 (defmacro nnmaildir--nov-set-mtime
(nov value
) `(aset ,nov
3 ,value
))
166 (defmacro nnmaildir--nov-set-extra
(nov value
) `(aset ,nov
4 ,value
))
168 (defstruct nnmaildir--art
169 (prefix nil
:type string
) ;; "time.pid.host"
170 (suffix nil
:type string
) ;; ":2,flags"
171 (num nil
:type natnum
) ;; article number
172 (msgid nil
:type string
) ;; "<mess.age@id>"
173 (nov nil
:type vector
)) ;; cached nov structure, or nil
175 (defstruct nnmaildir--grp
176 (name nil
:type string
) ;; "group.name"
177 (new nil
:type list
) ;; new/ modtime
178 (cur nil
:type list
) ;; cur/ modtime
179 (min 1 :type natnum
) ;; minimum article number
180 (count 0 :type natnum
) ;; count of articles
181 (nlist nil
:type list
) ;; list of articles, ordered descending by number
182 (flist nil
:type vector
) ;; obarray mapping filename prefix->article
183 (mlist nil
:type vector
) ;; obarray mapping message-id->article
184 (cache nil
:type vector
) ;; nov cache
185 (index nil
:type natnum
) ;; index of next cache entry to replace
186 (mmth nil
:type vector
)) ;; obarray mapping mark name->dir modtime
187 ; ("Mark Mod Time Hash")
189 (defstruct nnmaildir--srv
190 (address nil
:type string
) ;; server address string
191 (method nil
:type list
) ;; (nnmaildir "address" ...)
192 (prefix nil
:type string
) ;; "nnmaildir+address:"
193 (dir nil
:type string
) ;; "/expanded/path/to/server/dir/"
194 (ls nil
:type function
) ;; directory-files function
195 (groups nil
:type vector
) ;; obarray mapping group name->group
196 (curgrp nil
:type nnmaildir--grp
) ;; current group, or nil
197 (error nil
:type string
) ;; last error message, or nil
198 (mtime nil
:type list
) ;; modtime of dir
199 (gnm nil
) ;; flag: split from mail-sources?
200 (target-prefix nil
:type string
)) ;; symlink target prefix
202 (defun nnmaildir--article-set-flags (article new-suffix curdir
)
203 (let* ((prefix (nnmaildir--art-prefix article
))
204 (suffix (nnmaildir--art-suffix article
))
205 (article-file (concat curdir prefix suffix
))
206 (new-name (concat curdir prefix new-suffix
)))
207 (unless (file-exists-p article-file
)
208 (error "Couldn't find article file %s" article-file
))
209 (rename-file article-file new-name
'replace
)
210 (setf (nnmaildir--art-suffix article
) new-suffix
)))
212 (defun nnmaildir--expired-article (group article
)
213 (setf (nnmaildir--art-nov article
) nil
)
214 (let ((flist (nnmaildir--grp-flist group
))
215 (mlist (nnmaildir--grp-mlist group
))
216 (min (nnmaildir--grp-min group
))
217 (count (1- (nnmaildir--grp-count group
)))
218 (prefix (nnmaildir--art-prefix article
))
219 (msgid (nnmaildir--art-msgid article
))
221 (nlist-pre '(nil . nil
))
223 (unless (zerop count
)
224 (setq nlist-post
(nnmaildir--grp-nlist group
)
225 num
(nnmaildir--art-num article
))
226 (if (eq num
(caar nlist-post
))
227 (setq new-nlist
(cdr nlist-post
))
228 (setq new-nlist nlist-post
230 nlist-post
(cdr nlist-post
))
231 (while (/= num
(caar nlist-post
))
232 (setq nlist-pre nlist-post
233 nlist-post
(cdr nlist-post
)))
234 (setq nlist-post
(cdr nlist-post
))
236 (setq min
(caar nlist-pre
)))))
237 (let ((inhibit-quit t
))
238 (setf (nnmaildir--grp-min group
) min
)
239 (setf (nnmaildir--grp-count group
) count
)
240 (setf (nnmaildir--grp-nlist group
) new-nlist
)
241 (setcdr nlist-pre nlist-post
)
242 (unintern prefix flist
)
243 (unintern msgid mlist
))))
245 (defun nnmaildir--nlist-art (group num
)
246 (let ((entry (assq num
(nnmaildir--grp-nlist group
))))
249 (defmacro nnmaildir--flist-art
(list file
)
250 `(symbol-value (intern-soft ,file
,list
)))
251 (defmacro nnmaildir--mlist-art
(list msgid
)
252 `(symbol-value (intern-soft ,msgid
,list
)))
254 (defun nnmaildir--pgname (server gname
)
255 (let ((prefix (nnmaildir--srv-prefix server
)))
256 (if prefix
(concat prefix gname
)
257 (setq gname
(gnus-group-prefixed-name gname
258 (nnmaildir--srv-method server
)))
259 (setf (nnmaildir--srv-prefix server
) (gnus-group-real-prefix gname
))
262 (defun nnmaildir--param (pgname param
)
263 (setq param
(gnus-group-find-parameter pgname param
'allow-list
))
264 (if (vectorp param
) (setq param
(aref param
0)))
267 (defmacro nnmaildir--with-nntp-buffer
(&rest body
)
268 (declare (debug (body)))
269 `(with-current-buffer nntp-server-buffer
271 (defmacro nnmaildir--with-work-buffer
(&rest body
)
272 (declare (debug (body)))
273 `(with-current-buffer (get-buffer-create " *nnmaildir work*")
275 (defmacro nnmaildir--with-nov-buffer
(&rest body
)
276 (declare (debug (body)))
277 `(with-current-buffer (get-buffer-create " *nnmaildir nov*")
279 (defmacro nnmaildir--with-move-buffer
(&rest body
)
280 (declare (debug (body)))
281 `(with-current-buffer (get-buffer-create " *nnmaildir move*")
284 (defsubst nnmaildir--subdir
(dir subdir
)
285 (file-name-as-directory (concat dir subdir
)))
286 (defsubst nnmaildir--srvgrp-dir
(srv-dir gname
)
287 (nnmaildir--subdir srv-dir gname
))
288 (defsubst nnmaildir--tmp
(dir) (nnmaildir--subdir dir
"tmp"))
289 (defsubst nnmaildir--new
(dir) (nnmaildir--subdir dir
"new"))
290 (defsubst nnmaildir--cur
(dir) (nnmaildir--subdir dir
"cur"))
291 (defsubst nnmaildir--nndir
(dir) (nnmaildir--subdir dir
".nnmaildir"))
292 (defsubst nnmaildir--nov-dir
(dir) (nnmaildir--subdir dir
"nov"))
293 (defsubst nnmaildir--marks-dir
(dir) (nnmaildir--subdir dir
"marks"))
294 (defsubst nnmaildir--num-dir
(dir) (nnmaildir--subdir dir
"num"))
296 (defmacro nnmaildir--unlink
(file-arg)
297 `(let ((file ,file-arg
))
298 (if (file-attributes file
) (delete-file file
))))
299 (defun nnmaildir--mkdir (dir)
300 (or (file-exists-p (file-name-as-directory dir
))
301 (make-directory-internal (directory-file-name dir
))))
302 (defun nnmaildir--mkfile (file)
303 (write-region "" nil file nil
'no-message
))
304 (defun nnmaildir--delete-dir-files (dir ls
)
305 (when (file-attributes dir
)
306 (mapc 'delete-file
(funcall ls dir
'full
"\\`[^.]" 'nosort
))
307 (delete-directory dir
)))
309 (defun nnmaildir--group-maxnum (server group
)
311 (if (zerop (nnmaildir--grp-count group
)) (throw 'return
0))
312 (let ((dir (nnmaildir--srvgrp-dir (nnmaildir--srv-dir server
)
313 (nnmaildir--grp-name group
)))
315 attr ino-opened nlink number-linked
)
316 (setq dir
(nnmaildir--nndir dir
)
317 dir
(nnmaildir--num-dir dir
))
319 (setq attr
(file-attributes
320 (concat dir
(number-to-string number-opened
))))
321 (or attr
(throw 'return
(1- number-opened
)))
322 (setq ino-opened
(nth 10 attr
)
324 number-linked
(+ number-opened nlink
))
325 (if (or (< nlink
1) (< number-linked nlink
))
326 (signal 'error
'("Arithmetic overflow")))
327 (setq attr
(file-attributes
328 (concat dir
(number-to-string number-linked
))))
329 (or attr
(throw 'return
(1- number-linked
)))
330 (unless (equal ino-opened
(nth 10 attr
))
331 (setq number-opened number-linked
))))))
333 ;; Make the given server, if non-nil, be the current server. Then make the
334 ;; given group, if non-nil, be the current group of the current server. Then
335 ;; return the group object for the current group.
336 (defun nnmaildir--prepare (server group
)
339 (unless (setq server nnmaildir--cur-server
)
341 (unless (setq server
(intern-soft server nnmaildir--servers
))
343 (setq server
(symbol-value server
)
344 nnmaildir--cur-server server
))
345 (let ((groups (nnmaildir--srv-groups server
)))
347 (unless (nnmaildir--srv-method server
)
348 (setf (nnmaildir--srv-method server
)
349 (or (gnus-server-to-method
350 (concat "nnmaildir:" (nnmaildir--srv-address server
)))
351 (throw 'return nil
))))
353 (nnmaildir--srv-curgrp server
)
354 (symbol-value (intern-soft group groups
)))))))
356 (defun nnmaildir--tab-to-space (string)
358 (while (string-match "\t" string pos
)
359 (aset string
(match-beginning 0) ?
)
360 (setq pos
(match-end 0))))
363 (defmacro nnmaildir--condcase
(errsym body
&rest handler
)
364 (declare (debug (sexp form body
)))
365 `(condition-case ,errsym
366 (let ((system-messages-locale "C")) ,body
)
369 (defun nnmaildir--emlink-p (err)
370 (and (eq (car err
) 'file-error
)
371 (string= (downcase (caddr err
)) "too many links")))
373 (defun nnmaildir--enoent-p (err)
374 (eq (car err
) 'file-missing
))
376 (defun nnmaildir--eexist-p (err)
377 (eq (car err
) 'file-already-exists
))
379 (defun nnmaildir--new-number (nndir)
380 "Allocate a new article number by atomically creating a file under NNDIR."
381 (let ((numdir (nnmaildir--num-dir nndir
))
384 number-link previous-number-link path-open path-link ino-open
)
385 (nnmaildir--mkdir numdir
)
388 (setq path-open
(concat numdir
(number-to-string number-open
)))
389 (if (not make-new-file
)
390 (setq previous-number-link number-link
)
391 (nnmaildir--mkfile path-open
)
392 ;; If Emacs had O_CREAT|O_EXCL, we could return number-open here.
393 (setq make-new-file nil
394 previous-number-link
0))
395 (let* ((attr (file-attributes path-open
))
396 (nlink (nth 1 attr
)))
397 (setq ino-open
(nth 10 attr
)
398 number-link
(+ number-open nlink
))
399 (if (or (< nlink
1) (< number-link nlink
))
400 (signal 'error
'("Arithmetic overflow"))))
401 (if (= number-link previous-number-link
)
402 ;; We've already tried this number, in the previous loop iteration,
404 (signal 'error
`("Corrupt internal nnmaildir data" ,path-open
)))
405 (setq path-link
(concat numdir
(number-to-string number-link
)))
406 (nnmaildir--condcase err
408 (add-name-to-file path-open path-link
)
409 (throw 'return number-link
))
411 ((nnmaildir--emlink-p err
)
412 (setq make-new-file t
413 number-open number-link
))
414 ((nnmaildir--eexist-p err
)
415 (let ((attr (file-attributes path-link
)))
416 (unless (equal (nth 10 attr
) ino-open
)
417 (setq number-open number-link
419 (t (signal (car err
) (cdr err
)))))))))
421 (defun nnmaildir--update-nov (server group article
)
422 (let ((nnheader-file-coding-system 'binary
)
423 (srv-dir (nnmaildir--srv-dir server
))
424 (storage-version 1) ;; [version article-number msgid [...nov...]]
425 dir gname pgname msgdir prefix suffix file attr mtime novdir novfile
426 nov msgid nov-beg nov-mid nov-end field val old-extra num
429 (setq gname
(nnmaildir--grp-name group
)
430 pgname
(nnmaildir--pgname server gname
)
431 dir
(nnmaildir--srvgrp-dir srv-dir gname
)
432 msgdir
(if (nnmaildir--param pgname
'read-only
)
433 (nnmaildir--new dir
) (nnmaildir--cur dir
))
434 prefix
(nnmaildir--art-prefix article
)
435 suffix
(nnmaildir--art-suffix article
)
436 file
(concat msgdir prefix suffix
)
437 attr
(file-attributes file
))
439 (nnmaildir--expired-article group article
)
441 (setq mtime
(nth 5 attr
)
443 nov
(nnmaildir--art-nov article
)
444 dir
(nnmaildir--nndir dir
)
445 novdir
(nnmaildir--nov-dir dir
)
446 novfile
(concat novdir prefix
))
447 (unless (equal nnmaildir--extra nnmail-extra-headers
)
448 (setq nnmaildir--extra
(copy-sequence nnmail-extra-headers
)))
449 (nnmaildir--with-nov-buffer
450 ;; First we'll check for already-parsed NOV data.
451 (cond ((not (file-exists-p novfile
))
452 ;; The NOV file doesn't exist; we have to parse the message.
455 ;; The file exists, but the data isn't in memory; read the file.
457 (nnheader-insert-file-contents novfile
)
458 (setq nov
(read (current-buffer)))
459 (if (not (and (vectorp nov
)
461 (equal storage-version
(aref nov
0))))
462 ;; This NOV data seems to be in the wrong format.
464 (unless (nnmaildir--art-num article
)
465 (setf (nnmaildir--art-num article
) (aref nov
1)))
466 (unless (nnmaildir--art-msgid article
)
467 (setf (nnmaildir--art-msgid article
) (aref nov
2)))
468 (setq nov
(aref nov
3)))))
469 ;; Now check whether the already-parsed data (if we have any) is
470 ;; usable: if the message has been edited or if nnmail-extra-headers
471 ;; has been augmented since this data was parsed from the message,
472 ;; then we have to reparse. Otherwise it's up-to-date.
473 (when (and nov
(equal mtime
(nnmaildir--nov-get-mtime nov
)))
474 ;; The timestamp matches. Now check nnmail-extra-headers.
475 (setq old-extra
(nnmaildir--nov-get-extra nov
))
476 (when (equal nnmaildir--extra old-extra
) ;; common case
477 ;; Save memory; use a single copy of the list value.
478 (nnmaildir--nov-set-extra nov nnmaildir--extra
)
480 ;; They're not equal, but maybe the new is a subset of the old.
481 (if (null nnmaildir--extra
)
482 ;; The empty set is a subset of every set.
484 (if (not (memq nil
(mapcar (lambda (e) (memq e old-extra
))
486 (throw 'return nov
)))
487 ;; Parse the NOV data out of the message.
489 (nnheader-insert-file-contents file
)
491 (goto-char (point-min))
493 (if (search-forward "\n\n" nil
'noerror
)
495 (setq nov-mid
(count-lines (point) (point-max)))
496 (narrow-to-region (point-min) (1- (point))))
498 (goto-char (point-min))
500 (setq nov
(nnheader-parse-naked-head)
501 field
(or (mail-header-lines nov
) 0)))
502 (unless (or (zerop field
) (nnmaildir--param pgname
'distrust-Lines
:))
503 (setq nov-mid field
))
504 (setq nov-mid
(number-to-string nov-mid
)
505 nov-mid
(concat (number-to-string attr
) "\t" nov-mid
))
507 (setq field
(or (mail-header-references nov
) ""))
508 (nnmaildir--tab-to-space field
)
509 (setq nov-mid
(concat field
"\t" nov-mid
)
511 (lambda (f) (nnmaildir--tab-to-space (or f
"")))
512 (list (mail-header-subject nov
)
513 (mail-header-from nov
)
514 (mail-header-date nov
)) "\t")
517 (setq field
(symbol-name (car extra
))
519 (nnmaildir--tab-to-space field
)
520 (nnmaildir--tab-to-space val
)
521 (concat field
": " val
))
522 (mail-header-extra nov
) "\t")))
523 (setq msgid
(mail-header-id nov
))
524 (if (or (null msgid
) (nnheader-fake-message-id-p msgid
))
525 (setq msgid
(concat "<" prefix
"@nnmaildir>")))
526 (nnmaildir--tab-to-space msgid
)
527 ;; The data is parsed; create an nnmaildir NOV structure.
528 (setq nov
(nnmaildir--nov-new nov-beg nov-mid nov-end mtime
530 num
(nnmaildir--art-num article
))
532 (setq num
(nnmaildir--new-number dir
))
533 (setf (nnmaildir--art-num article
) num
))
534 ;; Store this new NOV data in a file
536 (prin1 (vector storage-version num msgid nov
) (current-buffer))
537 (setq file
(concat novfile
":"))
538 (nnmaildir--unlink file
)
539 (write-region (point-min) (point-max) file nil
'no-message nil
541 (rename-file file novfile
'replace
)
542 (setf (nnmaildir--art-msgid article
) msgid
)
545 (defun nnmaildir--cache-nov (group article nov
)
546 (let ((cache (nnmaildir--grp-cache group
))
547 (index (nnmaildir--grp-index group
))
549 (unless (nnmaildir--art-nov article
)
550 (setq goner
(aref cache index
))
551 (if goner
(setf (nnmaildir--art-nov goner
) nil
))
552 (aset cache index article
)
553 (setf (nnmaildir--grp-index group
) (%
(1+ index
) (length cache
))))
554 (setf (nnmaildir--art-nov article
) nov
)))
556 (defun nnmaildir--grp-add-art (server group article
)
557 (let ((nov (nnmaildir--update-nov server group article
))
558 count num min nlist nlist-cdr insert-nlist
)
560 (setq count
(1+ (nnmaildir--grp-count group
))
561 num
(nnmaildir--art-num article
)
562 min
(if (= count
1) num
563 (min num
(nnmaildir--grp-min group
)))
564 nlist
(nnmaildir--grp-nlist group
))
565 (if (or (null nlist
) (> num
(caar nlist
)))
566 (setq nlist
(cons (cons num article
) nlist
))
568 nlist-cdr
(cdr nlist
))
569 (while (and nlist-cdr
(< num
(caar nlist-cdr
)))
570 (setq nlist nlist-cdr
571 nlist-cdr
(cdr nlist
))))
572 (let ((inhibit-quit t
))
573 (setf (nnmaildir--grp-count group
) count
)
574 (setf (nnmaildir--grp-min group
) min
)
576 (setcdr nlist
(cons (cons num article
) nlist-cdr
))
577 (setf (nnmaildir--grp-nlist group
) nlist
))
578 (set (intern (nnmaildir--art-prefix article
)
579 (nnmaildir--grp-flist group
))
581 (set (intern (nnmaildir--art-msgid article
)
582 (nnmaildir--grp-mlist group
))
584 (set (intern (nnmaildir--grp-name group
)
585 (nnmaildir--srv-groups server
))
587 (nnmaildir--cache-nov group article nov
)
590 (defun nnmaildir--group-ls (server pgname
)
591 (or (nnmaildir--param pgname
'directory-files
)
592 (nnmaildir--srv-ls server
)))
594 (defun nnmaildir-article-number-to-file-name
595 (number group-name server-address-string
)
596 (let ((group (nnmaildir--prepare server-address-string group-name
))
600 ;; The given group or server does not exist.
602 (setq article
(nnmaildir--nlist-art group number
))
604 ;; The given article number does not exist in this group.
606 (setq pgname
(nnmaildir--pgname nnmaildir--cur-server group-name
)
607 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
608 dir
(nnmaildir--srvgrp-dir dir group-name
)
609 dir
(if (nnmaildir--param pgname
'read-only
)
610 (nnmaildir--new dir
) (nnmaildir--cur dir
)))
611 (concat dir
(nnmaildir--art-prefix article
)
612 (nnmaildir--art-suffix article
)))))
614 (defun nnmaildir-article-number-to-base-name
615 (number group-name server-address-string
)
616 (let ((x (nnmaildir--prepare server-address-string group-name
)))
618 (setq x
(nnmaildir--nlist-art x number
))
619 (and x
(cons (nnmaildir--art-prefix x
)
620 (nnmaildir--art-suffix x
))))))
622 (defun nnmaildir-base-name-to-article-number
623 (base-name group-name server-address-string
)
624 (let ((x (nnmaildir--prepare server-address-string group-name
)))
626 (setq x
(nnmaildir--grp-flist x
)
627 x
(nnmaildir--flist-art x base-name
))
628 (and x
(nnmaildir--art-num x
)))))
630 (defun nnmaildir--nlist-iterate (nlist ranges func
)
631 (let (entry high low nlist2
)
633 (setq ranges
`((1 .
,(caar nlist
)))))
635 (setq entry
(car ranges
) ranges
(cdr ranges
))
636 (while (and ranges
(eq entry
(car ranges
)))
637 (setq ranges
(cdr ranges
))) ;; skip duplicates
641 (setq low
(car entry
)
643 (setq nlist2 nlist
) ;; Don't assume any sorting of ranges
646 (if (<= (caar nlist2
) high
) (throw 'iterate-loop nil
))
647 (setq nlist2
(cdr nlist2
))))
650 (setq entry
(car nlist2
) nlist2
(cdr nlist2
))
651 (if (< (car entry
) low
) (throw 'iterate-loop nil
))
652 (funcall func
(cdr entry
)))))))
654 (defun nnmaildir--up2-1 (n)
655 (if (zerop n
) 1 (1- (lsh 1 (1+ (logb n
))))))
657 (defun nnmaildir--system-name ()
658 (replace-regexp-in-string
660 (replace-regexp-in-string
662 (replace-regexp-in-string "\\\\" "\\134" (system-name) nil
'literal
)
666 (defun nnmaildir-request-type (_group &optional _article
)
669 (defun nnmaildir-status-message (&optional server
)
670 (nnmaildir--prepare server nil
)
671 (nnmaildir--srv-error nnmaildir--cur-server
))
673 (defun nnmaildir-server-opened (&optional server
)
674 (and nnmaildir--cur-server
676 (string-equal server
(nnmaildir--srv-address nnmaildir--cur-server
))
678 (nnmaildir--srv-groups nnmaildir--cur-server
)
681 (defun nnmaildir-open-server (server &optional defs
)
685 (setq server
(intern-soft x nnmaildir--servers
))
687 (and (setq server
(symbol-value server
))
688 (nnmaildir--srv-groups server
)
689 (setq nnmaildir--cur-server server
)
691 (setq server
(make-nnmaildir--srv :address x
))
692 (let ((inhibit-quit t
))
693 (set (intern x nnmaildir--servers
) server
)))
694 (setq dir
(assq 'directory defs
))
696 (setf (nnmaildir--srv-error server
)
697 "You must set \"directory\" in the select method")
701 dir
(expand-file-name dir
)
702 dir
(file-name-as-directory dir
))
703 (unless (file-exists-p dir
)
704 (setf (nnmaildir--srv-error server
) (concat "No such directory: " dir
))
706 (setf (nnmaildir--srv-dir server
) dir
)
707 (setq x
(assq 'directory-files defs
))
709 (setq x
(if nnheader-directory-files-is-safe
'directory-files
710 'nnheader-directory-files-safe
))
712 (unless (functionp x
)
713 (setf (nnmaildir--srv-error server
)
714 (concat "Not a function: " (prin1-to-string x
)))
715 (throw 'return nil
)))
716 (setf (nnmaildir--srv-ls server
) x
)
717 (setq size
(length (funcall x dir nil
"\\`[^.]" 'nosort
))
718 size
(nnmaildir--up2-1 size
))
719 (and (setq x
(assq 'get-new-mail defs
))
722 (setf (nnmaildir--srv-gnm server
) t
)
724 (setq x
(assq 'target-prefix defs
))
729 (setf (nnmaildir--srv-target-prefix server
) x
))
730 (setq x
(assq 'create-directory defs
))
735 x
(file-name-as-directory x
))
736 (setf (nnmaildir--srv-target-prefix server
) x
))
737 (setf (nnmaildir--srv-target-prefix server
) "")))
738 (setf (nnmaildir--srv-groups server
) (make-vector size
0))
739 (setq nnmaildir--cur-server server
)
742 (defun nnmaildir--parse-filename (file)
743 (let ((prefix (car file
))
745 (if (string-match "\\`\\([0-9]+\\)\\(\\..*\\)\\'" prefix
)
747 (setq timestamp
(concat "0000" (match-string 1 prefix
))
748 len
(- (length timestamp
) 4))
749 (vector (string-to-number (substring timestamp
0 len
))
750 (string-to-number (substring timestamp len
))
751 (match-string 2 prefix
)
755 (defun nnmaildir--sort-files (a b
)
758 (throw 'return
(and (consp b
) (string-lessp (car a
) (car b
)))))
759 (if (consp b
) (throw 'return t
))
760 (if (< (aref a
0) (aref b
0)) (throw 'return t
))
761 (if (> (aref a
0) (aref b
0)) (throw 'return nil
))
762 (if (< (aref a
1) (aref b
1)) (throw 'return t
))
763 (if (> (aref a
1) (aref b
1)) (throw 'return nil
))
764 (string-lessp (aref a
2) (aref b
2))))
766 (defun nnmaildir--scan (gname scan-msgs groups _method srv-dir srv-ls
)
768 (let ((36h-ago (- (car (current-time)) 2))
769 absdir nndir tdir ndir cdir nattr cattr isnew pgname read-only ls
770 files num dir flist group x
)
771 (setq absdir
(nnmaildir--srvgrp-dir srv-dir gname
)
772 nndir
(nnmaildir--nndir absdir
))
773 (unless (file-exists-p absdir
)
774 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
775 (concat "No such directory: " absdir
))
777 (setq tdir
(nnmaildir--tmp absdir
)
778 ndir
(nnmaildir--new absdir
)
779 cdir
(nnmaildir--cur absdir
)
780 nattr
(file-attributes ndir
)
781 cattr
(file-attributes cdir
))
782 (unless (and (file-exists-p tdir
) nattr cattr
)
783 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
784 (concat "Not a maildir: " absdir
))
786 (setq group
(nnmaildir--prepare nil gname
)
787 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
))
791 group
(make-nnmaildir--grp :name gname
:index
0))
792 (nnmaildir--mkdir nndir
)
793 (nnmaildir--mkdir (nnmaildir--nov-dir nndir
))
794 (nnmaildir--mkdir (nnmaildir--marks-dir nndir
)))
795 (setq read-only
(nnmaildir--param pgname
'read-only
)
796 ls
(or (nnmaildir--param pgname
'directory-files
) srv-ls
))
798 (setq x
(nth 11 (file-attributes tdir
)))
799 (unless (and (equal x
(nth 11 nattr
)) (equal x
(nth 11 cattr
)))
800 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
801 (concat "Maildir spans filesystems: " absdir
))
803 (dolist (file (funcall ls tdir
'full
"\\`[^.]" 'nosort
))
804 (setq x
(file-attributes file
))
805 (if (or (> (cadr x
) 1) (< (car (nth 4 x
)) 36h-ago
))
806 (delete-file file
))))
810 (setq nattr
(nth 5 nattr
))
811 (if (equal nattr
(nnmaildir--grp-new group
))
813 (if read-only
(setq dir
(and (or isnew nattr
) ndir
))
814 (when (or isnew nattr
)
815 (dolist (file (funcall ls ndir nil
"\\`[^.]" 'nosort
))
816 (setq x
(concat ndir file
))
817 (and (time-less-p (nth 5 (file-attributes x
)) nil
)
818 (rename-file x
(concat cdir
(nnmaildir--ensure-suffix file
)))))
819 (setf (nnmaildir--grp-new group
) nattr
))
820 (setq cattr
(nth 5 (file-attributes cdir
)))
821 (if (equal cattr
(nnmaildir--grp-cur group
))
823 (setq dir
(and (or isnew cattr
) cdir
)))
824 (unless dir
(throw 'return t
))
825 (setq files
(funcall ls dir nil
"\\`[^.]" 'nosort
)
826 files
(save-match-data
829 (string-match "\\`\\([^:]*\\)\\(\\(:.*\\)?\\)\\'" f
)
830 (cons (match-string 1 f
) (match-string 2 f
)))
833 (setq num
(nnmaildir--up2-1 (length files
)))
834 (setf (nnmaildir--grp-flist group
) (make-vector num
0))
835 (setf (nnmaildir--grp-mlist group
) (make-vector num
0))
836 (setf (nnmaildir--grp-mmth group
) (make-vector 1 0))
837 (setq num
(nnmaildir--param pgname
'nov-cache-size
))
838 (if (numberp num
) (if (< num
1) (setq num
1))
840 cdir
(nnmaildir--marks-dir nndir
)
841 ndir
(nnmaildir--subdir cdir
"tick")
842 cdir
(nnmaildir--subdir cdir
"read"))
843 (dolist (prefix-suffix files
)
844 (let ((prefix (car prefix-suffix
))
845 (suffix (cdr prefix-suffix
)))
846 ;; increase num for each unread or ticked article
848 ;; first look for marks in suffix, if it's valid...
849 (when (and (stringp suffix
)
850 (string-prefix-p ":2," suffix
))
853 (string (nnmaildir--mark-to-flag 'read
)) suffix
))
855 (string (nnmaildir--mark-to-flag 'tick
)) suffix
)))
856 ;; then look in marks directories
857 (not (file-exists-p (concat cdir prefix
)))
858 (file-exists-p (concat ndir prefix
)))
860 (setf (nnmaildir--grp-cache group
) (make-vector num nil
))
861 (let ((inhibit-quit t
))
862 (set (intern gname groups
) group
))
863 (or scan-msgs
(throw 'return t
)))
864 (setq flist
(nnmaildir--grp-flist group
)
867 (and (null (nnmaildir--flist-art flist
(car file
)))
870 files
(delq nil files
)
871 files
(mapcar 'nnmaildir--parse-filename files
)
872 files
(sort files
'nnmaildir--sort-files
))
874 (setq file
(if (consp file
) file
(aref file
3))
875 x
(make-nnmaildir--art :prefix
(car file
) :suffix
(cdr file
)))
876 (nnmaildir--grp-add-art nnmaildir--cur-server group x
))
877 (if read-only
(setf (nnmaildir--grp-new group
) nattr
)
878 (setf (nnmaildir--grp-cur group
) cattr
)))
881 (defvar nnmaildir-get-new-mail
)
882 (defvar nnmaildir-group-alist
)
883 (defvar nnmaildir-active-file
)
885 (defun nnmaildir-request-scan (&optional scan-group server
)
886 (let ((coding-system-for-write nnheader-file-coding-system
)
887 (buffer-file-coding-system nil
)
888 (file-coding-system-alist nil
)
889 (nnmaildir-get-new-mail t
)
890 (nnmaildir-group-alist nil
)
891 (nnmaildir-active-file nil
)
892 x srv-ls srv-dir method groups target-prefix dirs seen
894 (nnmaildir--prepare server nil
)
895 (setq srv-ls
(nnmaildir--srv-ls nnmaildir--cur-server
)
896 srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
897 method
(nnmaildir--srv-method nnmaildir--cur-server
)
898 groups
(nnmaildir--srv-groups nnmaildir--cur-server
)
899 target-prefix
(nnmaildir--srv-target-prefix nnmaildir--cur-server
))
900 (nnmaildir--with-work-buffer
902 (if (stringp scan-group
)
903 (if (nnmaildir--scan scan-group t groups method srv-dir srv-ls
)
904 (if (nnmaildir--srv-gnm nnmaildir--cur-server
)
905 (nnmail-get-new-mail 'nnmaildir nil nil scan-group
))
906 (unintern scan-group groups
))
907 (setq x
(nth 5 (file-attributes srv-dir
))
908 scan-group
(null scan-group
))
909 (if (equal x
(nnmaildir--srv-mtime nnmaildir--cur-server
))
911 (mapatoms (lambda (sym)
912 (nnmaildir--scan (symbol-name sym
) t groups
913 method srv-dir srv-ls
))
915 (setq dirs
(funcall srv-ls srv-dir nil
"\\`[^.]" 'nosort
)
916 dirs
(if (zerop (length target-prefix
))
920 (and (>= (length dir
) (length target-prefix
))
921 (string= (substring dir
0
922 (length target-prefix
))
925 seen
(nnmaildir--up2-1 (length dirs
))
926 seen
(make-vector seen
0))
927 (dolist (grp-dir dirs
)
928 (if (nnmaildir--scan grp-dir scan-group groups method srv-dir
930 (intern grp-dir seen
)))
932 (mapatoms (lambda (group)
933 (setq group
(symbol-name group
))
934 (unless (intern-soft group seen
)
935 (setq x
(cons group x
))))
938 (unintern grp groups
))
939 (setf (nnmaildir--srv-mtime nnmaildir--cur-server
)
940 (nth 5 (file-attributes srv-dir
))))
942 (nnmaildir--srv-gnm nnmaildir--cur-server
)
943 (nnmail-get-new-mail 'nnmaildir nil nil
))))))
946 (defun nnmaildir-request-list (&optional server
)
947 (nnmaildir-request-scan 'find-new-groups server
)
948 (let (pgname ro deactivate-mark
)
949 (nnmaildir--prepare server nil
)
950 (nnmaildir--with-nntp-buffer
952 (mapatoms (lambda (group)
953 (setq pgname
(symbol-name group
)
954 pgname
(nnmaildir--pgname nnmaildir--cur-server pgname
)
955 group
(symbol-value group
)
956 ro
(nnmaildir--param pgname
'read-only
))
957 (insert (replace-regexp-in-string
959 (nnmaildir--grp-name group
) nil t
)
961 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group
)
964 (princ (nnmaildir--grp-min group
) nntp-server-buffer
)
965 (insert " " (if ro
"n" "y") "\n"))
966 (nnmaildir--srv-groups nnmaildir--cur-server
))))
969 (defun nnmaildir-request-newgroups (_date &optional server
)
970 (nnmaildir-request-list server
))
972 (defun nnmaildir-retrieve-groups (groups &optional server
)
973 (let (group deactivate-mark
)
974 (nnmaildir--prepare server nil
)
975 (nnmaildir--with-nntp-buffer
977 (dolist (gname groups
)
978 (setq group
(nnmaildir--prepare nil gname
))
979 (if (null group
) (insert "411 no such news group\n")
981 (princ (nnmaildir--grp-count group
) nntp-server-buffer
)
983 (princ (nnmaildir--grp-min group
) nntp-server-buffer
)
985 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group
)
988 (replace-regexp-in-string " " "\\ " gname nil t
)
992 (defun nnmaildir-request-update-info (gname info
&optional server
)
993 (let* ((group (nnmaildir--prepare server gname
))
994 (curdir (nnmaildir--cur
995 (nnmaildir--srvgrp-dir
996 (nnmaildir--srv-dir nnmaildir--cur-server
) gname
)))
997 (curdir-mtime (nth 5 (file-attributes curdir
)))
998 pgname flist always-marks never-marks old-marks dir
999 all-marks marks ranges markdir read ls
1000 old-mmth new-mmth mtime existing missing deactivate-mark
)
1003 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1004 (concat "No such group: " gname
))
1005 (throw 'return nil
))
1006 (setq gname
(nnmaildir--grp-name group
)
1007 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1008 flist
(nnmaildir--grp-flist group
))
1009 (when (zerop (nnmaildir--grp-count group
))
1010 (gnus-info-set-read info nil
)
1011 (gnus-info-set-marks info nil
'extend
)
1012 (throw 'return info
))
1013 (setq old-marks
(cons 'read
(gnus-info-read info
))
1014 old-marks
(cons old-marks
(gnus-info-marks info
))
1015 always-marks
(nnmaildir--param pgname
'always-marks
)
1016 never-marks
(nnmaildir--param pgname
'never-marks
)
1017 existing
(nnmaildir--grp-nlist group
)
1018 existing
(mapcar 'car existing
)
1019 existing
(nreverse existing
)
1020 existing
(gnus-compress-sequence existing
'always-list
)
1021 missing
(list (cons 1 (nnmaildir--group-maxnum
1022 nnmaildir--cur-server group
)))
1023 missing
(gnus-range-difference missing existing
)
1024 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1025 dir
(nnmaildir--srvgrp-dir dir gname
)
1026 dir
(nnmaildir--nndir dir
)
1027 dir
(nnmaildir--marks-dir dir
)
1028 ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
)
1029 all-marks
(gnus-delete-duplicates
1030 ;; get mark names from mark dirs and from flag
1033 (mapcar 'cdr nnmaildir-flag-mark-mapping
)
1034 (mapcar 'intern
(funcall ls dir nil
"\\`[^.]" 'nosort
))))
1035 new-mmth
(nnmaildir--up2-1 (length all-marks
))
1036 new-mmth
(make-vector new-mmth
0)
1037 old-mmth
(nnmaildir--grp-mmth group
))
1038 (dolist (mark all-marks
)
1039 (setq markdir
(nnmaildir--subdir dir
(symbol-name mark
))
1042 (if (memq mark never-marks
) (throw 'got-ranges nil
))
1043 (when (memq mark always-marks
)
1044 (setq ranges existing
)
1045 (throw 'got-ranges nil
))
1046 ;; Find the mtime for this mark. If this mark can be expressed as
1047 ;; a filename flag, get the later of the mtimes for markdir and
1048 ;; curdir, otherwise only the markdir counts.
1050 (let ((markdir-mtime (nth 5 (file-attributes markdir
))))
1052 ((null (nnmaildir--mark-to-flag mark
))
1054 ((null markdir-mtime
)
1056 ((null curdir-mtime
)
1057 ;; this should never happen...
1059 ((time-less-p markdir-mtime curdir-mtime
)
1063 (set (intern (symbol-name mark
) new-mmth
) mtime
)
1064 (when (equal mtime
(symbol-value (intern-soft (symbol-name mark
) old-mmth
)))
1065 (setq ranges
(assq mark old-marks
))
1066 (if ranges
(setq ranges
(cdr ranges
)))
1067 (throw 'got-ranges nil
))
1068 (let ((article-list nil
))
1069 ;; Consider the article marked if it either has the flag in the
1070 ;; filename, or is in the markdir. As you'd rarely remove a
1071 ;; flag/mark, this should avoid losing information in the most
1072 ;; common usage pattern.
1074 (let ((flag (nnmaildir--mark-to-flag mark
)))
1075 ;; If this mark has a corresponding maildir flag...
1078 (concat "\\`[^.].*:2,[A-Z]*" (string flag
))))
1079 ;; ...then find all files with that flag.
1080 (dolist (filename (funcall ls curdir nil regexp
'nosort
))
1081 (let* ((prefix (car (split-string filename
":2,")))
1082 (article (nnmaildir--flist-art flist prefix
)))
1084 (push (nnmaildir--art-num article
) article-list
)))))))
1085 ;; Also check Gnus-specific mark directory, if it exists.
1086 (when (file-directory-p markdir
)
1087 (dolist (prefix (funcall ls markdir nil
"\\`[^.]" 'nosort
))
1088 (let ((article (nnmaildir--flist-art flist prefix
)))
1090 (push (nnmaildir--art-num article
) article-list
))))))
1091 (setq ranges
(gnus-add-to-range ranges
(sort article-list
'<)))))
1092 (if (eq mark
'read
) (setq read ranges
)
1093 (if ranges
(setq marks
(cons (cons mark ranges
) marks
)))))
1094 (gnus-info-set-read info
(gnus-range-add read missing
))
1095 (gnus-info-set-marks info marks
'extend
)
1096 (setf (nnmaildir--grp-mmth group
) new-mmth
)
1099 (defun nnmaildir-request-group (gname &optional server fast _info
)
1100 (let ((group (nnmaildir--prepare server gname
))
1104 ;; (insert "411 no such news group\n")
1105 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1106 (concat "No such group: " gname
))
1107 (throw 'return nil
))
1108 (setf (nnmaildir--srv-curgrp nnmaildir--cur-server
) group
)
1109 (if fast
(throw 'return t
))
1110 (nnmaildir--with-nntp-buffer
1113 (princ (nnmaildir--grp-count group
) nntp-server-buffer
)
1115 (princ (nnmaildir--grp-min group
) nntp-server-buffer
)
1117 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group
)
1119 (insert " " (replace-regexp-in-string " " "\\ " gname nil t
) "\n")
1122 (defun nnmaildir-request-create-group (gname &optional server _args
)
1123 (nnmaildir--prepare server nil
)
1125 (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server
))
1127 (when (zerop (length gname
))
1128 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1129 "Invalid (empty) group name")
1130 (throw 'return nil
))
1131 (when (eq (aref "." 0) (aref gname
0))
1132 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1133 "Group names may not start with \".\"")
1134 (throw 'return nil
))
1135 (when (save-match-data (string-match "[\0/\t]" gname
))
1136 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1137 (concat "Invalid characters (null, tab, or /) in group name: "
1139 (throw 'return nil
))
1140 (setq groups
(nnmaildir--srv-groups nnmaildir--cur-server
))
1141 (when (intern-soft gname groups
)
1142 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1143 (concat "Group already exists: " gname
))
1144 (throw 'return nil
))
1145 (setq srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
))
1146 (if (file-name-absolute-p target-prefix
)
1147 (setq dir
(expand-file-name target-prefix
))
1149 dir
(file-truename dir
)
1150 dir
(concat dir target-prefix
)))
1151 (setq dir
(nnmaildir--subdir dir gname
))
1152 (nnmaildir--mkdir dir
)
1153 (nnmaildir--mkdir (nnmaildir--tmp dir
))
1154 (nnmaildir--mkdir (nnmaildir--new dir
))
1155 (nnmaildir--mkdir (nnmaildir--cur dir
))
1156 (unless (string= target-prefix
"")
1157 (make-symbolic-link (concat target-prefix gname
)
1158 (concat srv-dir gname
)))
1159 (nnmaildir-request-scan 'find-new-groups
))))
1161 (defun nnmaildir-request-rename-group (gname new-name
&optional server
)
1162 (let ((group (nnmaildir--prepare server gname
))
1163 (coding-system-for-write nnheader-file-coding-system
)
1164 (buffer-file-coding-system nil
)
1165 (file-coding-system-alist nil
)
1169 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1170 (concat "No such group: " gname
))
1171 (throw 'return nil
))
1172 (when (zerop (length new-name
))
1173 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1174 "Invalid (empty) group name")
1175 (throw 'return nil
))
1176 (when (eq (aref "." 0) (aref new-name
0))
1177 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1178 "Group names may not start with \".\"")
1179 (throw 'return nil
))
1180 (when (save-match-data (string-match "[\0/\t]" new-name
))
1181 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1182 (concat "Invalid characters (null, tab, or /) in group name: "
1184 (throw 'return nil
))
1185 (if (string-equal gname new-name
) (throw 'return t
))
1186 (when (intern-soft new-name
1187 (nnmaildir--srv-groups nnmaildir--cur-server
))
1188 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1189 (concat "Group already exists: " new-name
))
1190 (throw 'return nil
))
1191 (setq srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
))
1193 (rename-file (concat srv-dir gname
)
1194 (concat srv-dir new-name
))
1196 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1197 (concat "Error renaming link: " (prin1-to-string err
)))
1198 (throw 'return nil
)))
1199 (setq x
(nnmaildir--srv-groups nnmaildir--cur-server
)
1200 groups
(make-vector (length x
) 0))
1201 (mapatoms (lambda (sym)
1202 (unless (eq (symbol-value sym
) group
)
1203 (set (intern (symbol-name sym
) groups
)
1204 (symbol-value sym
))))
1206 (setq group
(copy-sequence group
))
1207 (setf (nnmaildir--grp-name group
) new-name
)
1208 (set (intern new-name groups
) group
)
1209 (setf (nnmaildir--srv-groups nnmaildir--cur-server
) groups
)
1212 (defun nnmaildir-request-delete-group (gname force
&optional server
)
1213 (let ((group (nnmaildir--prepare server gname
))
1214 pgname grp-dir target dir ls deactivate-mark
)
1217 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1218 (concat "No such group: " gname
))
1219 (throw 'return nil
))
1220 (setq gname
(nnmaildir--grp-name group
)
1221 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1222 grp-dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1223 target
(car (file-attributes (concat grp-dir gname
)))
1224 grp-dir
(nnmaildir--srvgrp-dir grp-dir gname
))
1225 (unless (or force
(stringp target
))
1226 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1227 (concat "Not a symlink: " gname
))
1228 (throw 'return nil
))
1229 (if (eq group
(nnmaildir--srv-curgrp nnmaildir--cur-server
))
1230 (setf (nnmaildir--srv-curgrp nnmaildir--cur-server
) nil
))
1231 (unintern gname
(nnmaildir--srv-groups nnmaildir--cur-server
))
1234 (setq grp-dir
(directory-file-name grp-dir
))
1235 (nnmaildir--unlink grp-dir
))
1236 (setq ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
))
1237 (if (nnmaildir--param pgname
'read-only
)
1238 (progn (delete-directory (nnmaildir--tmp grp-dir
))
1239 (nnmaildir--unlink (nnmaildir--new grp-dir
))
1240 (delete-directory (nnmaildir--cur grp-dir
)))
1241 (nnmaildir--delete-dir-files (nnmaildir--tmp grp-dir
) ls
)
1242 (nnmaildir--delete-dir-files (nnmaildir--new grp-dir
) ls
)
1243 (nnmaildir--delete-dir-files (nnmaildir--cur grp-dir
) ls
))
1244 (setq dir
(nnmaildir--nndir grp-dir
))
1245 (dolist (subdir `(,(nnmaildir--nov-dir dir
) ,(nnmaildir--num-dir dir
)
1246 ,@(funcall ls
(nnmaildir--marks-dir dir
)
1247 'full
"\\`[^.]" 'nosort
)))
1248 (nnmaildir--delete-dir-files subdir ls
))
1249 (setq dir
(nnmaildir--nndir grp-dir
))
1250 (nnmaildir--unlink (concat dir
"markfile"))
1251 (nnmaildir--unlink (concat dir
"markfile{new}"))
1252 (delete-directory (nnmaildir--marks-dir dir
))
1253 (delete-directory dir
)
1254 (if (not (stringp target
))
1255 (delete-directory grp-dir
)
1256 (setq grp-dir
(directory-file-name grp-dir
)
1258 (unless (eq (aref "/" 0) (aref dir
0))
1259 (setq dir
(concat (file-truename
1260 (nnmaildir--srv-dir nnmaildir--cur-server
))
1262 (delete-directory dir
)
1263 (nnmaildir--unlink grp-dir
)))
1266 (defun nnmaildir-retrieve-headers (articles &optional gname server fetch-old
)
1267 (let ((group (nnmaildir--prepare server gname
))
1268 nlist mlist article num start stop nov insert-nov
1272 (setq nov
(nnmaildir--update-nov nnmaildir--cur-server group
1275 (nnmaildir--cache-nov group article nov
)
1276 (setq num
(nnmaildir--art-num article
))
1277 (princ num nntp-server-buffer
)
1278 (insert "\t" (nnmaildir--nov-get-beg nov
) "\t"
1279 (nnmaildir--art-msgid article
) "\t"
1280 (nnmaildir--nov-get-mid nov
) "\tXref: nnmaildir "
1281 (replace-regexp-in-string " " "\\ " gname nil t
) ":")
1282 (princ num nntp-server-buffer
)
1283 (insert "\t" (nnmaildir--nov-get-end nov
) "\n"))))
1286 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1287 (if gname
(concat "No such group: " gname
) "No current group"))
1288 (throw 'return nil
))
1289 (nnmaildir--with-nntp-buffer
1291 (setq mlist
(nnmaildir--grp-mlist group
)
1292 nlist
(nnmaildir--grp-nlist group
)
1293 gname
(nnmaildir--grp-name group
))
1296 ((and fetch-old
(not (numberp fetch-old
)))
1297 (nnmaildir--nlist-iterate nlist
'all insert-nov
))
1299 ((stringp (car articles
))
1300 (dolist (msgid articles
)
1301 (setq article
(nnmaildir--mlist-art mlist msgid
))
1302 (if article
(funcall insert-nov article
))))
1305 ;; Assume the article range list is sorted ascending
1306 (setq stop
(car articles
)
1307 start
(car (last articles
))
1308 stop
(if (numberp stop
) stop
(car stop
))
1309 start
(if (numberp start
) start
(cdr start
))
1310 stop
(- stop fetch-old
)
1311 stop
(if (< stop
1) 1 stop
)
1312 articles
(list (cons stop start
))))
1313 (nnmaildir--nlist-iterate nlist articles insert-nov
)))
1314 (sort-numeric-fields 1 (point-min) (point-max))
1317 (defun nnmaildir-request-article (num-msgid &optional gname server to-buffer
)
1318 (let ((group (nnmaildir--prepare server gname
))
1319 (case-fold-search t
)
1320 list article dir pgname deactivate-mark
)
1323 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1324 (if gname
(concat "No such group: " gname
) "No current group"))
1325 (throw 'return nil
))
1326 (if (numberp num-msgid
)
1327 (setq article
(nnmaildir--nlist-art group num-msgid
))
1328 (setq list
(nnmaildir--grp-mlist group
)
1329 article
(nnmaildir--mlist-art list num-msgid
))
1330 (if article
(setq num-msgid
(nnmaildir--art-num article
))
1334 (setq group
(symbol-value group-sym
)
1335 list
(nnmaildir--grp-mlist group
)
1336 article
(nnmaildir--mlist-art list num-msgid
))
1338 (setq num-msgid
(nnmaildir--art-num article
))
1339 (throw 'found nil
)))
1340 (nnmaildir--srv-groups nnmaildir--cur-server
))))
1342 (setf (nnmaildir--srv-error nnmaildir--cur-server
) "No such article")
1343 (throw 'return nil
)))
1344 (setq gname
(nnmaildir--grp-name group
)
1345 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1346 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1347 dir
(nnmaildir--srvgrp-dir dir gname
)
1348 dir
(if (nnmaildir--param pgname
'read-only
)
1349 (nnmaildir--new dir
) (nnmaildir--cur dir
))
1350 nnmaildir-article-file-name
1352 (nnmaildir--art-prefix article
)
1353 (nnmaildir--art-suffix article
)))
1354 (unless (file-exists-p nnmaildir-article-file-name
)
1355 (nnmaildir--expired-article group article
)
1356 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1357 "Article has expired")
1358 (throw 'return nil
))
1359 (with-current-buffer (or to-buffer nntp-server-buffer
)
1361 (nnheader-insert-file-contents nnmaildir-article-file-name
))
1362 (cons gname num-msgid
))))
1364 (defun nnmaildir-request-post (&optional _server
)
1365 (let (message-required-mail-headers)
1366 (funcall message-send-mail-function
)))
1368 (defun nnmaildir-request-replace-article (number gname buffer
)
1369 (let ((group (nnmaildir--prepare nil gname
))
1370 (coding-system-for-write nnheader-file-coding-system
)
1371 (buffer-file-coding-system nil
)
1372 (file-coding-system-alist nil
)
1373 dir file article suffix tmpfile deactivate-mark
)
1376 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1377 (concat "No such group: " gname
))
1378 (throw 'return nil
))
1379 (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname
)
1381 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1382 (concat "Read-only group: " group
))
1383 (throw 'return nil
))
1384 (setq dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1385 dir
(nnmaildir--srvgrp-dir dir gname
)
1386 article
(nnmaildir--nlist-art group number
))
1388 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1389 (concat "No such article: " (number-to-string number
)))
1390 (throw 'return nil
))
1391 (setq suffix
(nnmaildir--art-suffix article
)
1392 file
(nnmaildir--art-prefix article
)
1393 tmpfile
(concat (nnmaildir--tmp dir
) file
))
1394 (when (file-exists-p tmpfile
)
1395 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1396 (concat "File exists: " tmpfile
))
1397 (throw 'return nil
))
1398 (with-current-buffer buffer
1399 (write-region (point-min) (point-max) tmpfile nil
'no-message nil
1401 (unix-sync) ;; no fsync :(
1402 (rename-file tmpfile
(concat (nnmaildir--cur dir
) file suffix
) 'replace
)
1405 (defun nnmaildir-request-move-article (article gname server accept-form
1406 &optional _last _move-is-internal
)
1407 (let ((group (nnmaildir--prepare server gname
))
1408 pgname suffix result nnmaildir--file deactivate-mark
)
1411 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1412 (concat "No such group: " gname
))
1413 (throw 'return nil
))
1414 (setq gname
(nnmaildir--grp-name group
)
1415 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1416 article
(nnmaildir--nlist-art group article
))
1418 (setf (nnmaildir--srv-error nnmaildir--cur-server
) "No such article")
1419 (throw 'return nil
))
1420 (setq suffix
(nnmaildir--art-suffix article
)
1421 nnmaildir--file
(nnmaildir--srv-dir nnmaildir--cur-server
)
1422 nnmaildir--file
(nnmaildir--srvgrp-dir nnmaildir--file gname
)
1423 nnmaildir--file
(if (nnmaildir--param pgname
'read-only
)
1424 (nnmaildir--new nnmaildir--file
)
1425 (nnmaildir--cur nnmaildir--file
))
1426 nnmaildir--file
(concat nnmaildir--file
1427 (nnmaildir--art-prefix article
)
1429 (unless (file-exists-p nnmaildir--file
)
1430 (nnmaildir--expired-article group article
)
1431 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1432 "Article has expired")
1433 (throw 'return nil
))
1434 (nnmaildir--with-move-buffer
1436 (nnheader-insert-file-contents nnmaildir--file
)
1437 (setq result
(eval accept-form
)))
1438 (unless (or (null result
) (nnmaildir--param pgname
'read-only
))
1439 (nnmaildir--unlink nnmaildir--file
)
1440 (nnmaildir--expired-article group article
))
1443 (defun nnmaildir-request-accept-article (gname &optional server _last
)
1444 (let ((group (nnmaildir--prepare server gname
))
1445 (coding-system-for-write nnheader-file-coding-system
)
1446 (buffer-file-coding-system nil
)
1447 (file-coding-system-alist nil
)
1448 srv-dir dir file time tmpfile curfile
24h article
)
1451 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1452 (concat "No such group: " gname
))
1453 (throw 'return nil
))
1454 (setq gname
(nnmaildir--grp-name group
))
1455 (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname
)
1457 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1458 (concat "Read-only group: " gname
))
1459 (throw 'return nil
))
1460 (setq srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1461 dir
(nnmaildir--srvgrp-dir srv-dir gname
)
1463 file
(format-time-string "%s." time
))
1464 (unless (string-equal nnmaildir--delivery-time file
)
1465 (setq nnmaildir--delivery-time file
1466 nnmaildir--delivery-count
0))
1467 (when (and (consp (cdr time
))
1468 (consp (cddr time
)))
1469 (setq file
(concat file
"M" (number-to-string (caddr time
)))))
1470 (setq file
(concat file nnmaildir--delivery-pid
)
1471 file
(concat file
"Q" (number-to-string nnmaildir--delivery-count
))
1472 file
(concat file
"." (nnmaildir--system-name))
1473 tmpfile
(concat (nnmaildir--tmp dir
) file
)
1474 curfile
(concat (nnmaildir--cur dir
) file
":2,"))
1475 (when (file-exists-p tmpfile
)
1476 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1477 (concat "File exists: " tmpfile
))
1478 (throw 'return nil
))
1479 (when (file-exists-p curfile
)
1480 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1481 (concat "File exists: " curfile
))
1482 (throw 'return nil
))
1483 (setq nnmaildir--delivery-count
(1+ nnmaildir--delivery-count
)
1484 24h
(run-with-timer 86400 nil
1486 (nnmaildir--unlink tmpfile
)
1487 (setf (nnmaildir--srv-error
1488 nnmaildir--cur-server
)
1489 "24-hour timer expired")
1490 (throw 'return nil
))))
1491 (condition-case nil
(add-name-to-file nnmaildir--file tmpfile
)
1493 (write-region (point-min) (point-max) tmpfile nil
'no-message nil
1495 (when (fboundp 'unix-sync
)
1496 (unix-sync)))) ;; no fsync :(
1497 (nnheader-cancel-timer 24h
)
1499 (add-name-to-file tmpfile curfile
)
1501 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1502 (concat "Error linking: " (prin1-to-string err
)))
1503 (nnmaildir--unlink tmpfile
)
1504 (throw 'return nil
)))
1505 (nnmaildir--unlink tmpfile
)
1506 (setq article
(make-nnmaildir--art :prefix file
:suffix
":2,"))
1507 (if (nnmaildir--grp-add-art nnmaildir--cur-server group article
)
1508 (cons gname
(nnmaildir--art-num article
))))))
1510 (defun nnmaildir-save-mail (group-art)
1513 (throw 'return nil
))
1514 (let (ga gname x groups nnmaildir--file deactivate-mark
)
1516 (goto-char (point-min))
1518 (while (looking-at "From ")
1519 (replace-match "X-From-Line: ")
1521 (setq groups
(nnmaildir--srv-groups nnmaildir--cur-server
)
1522 ga
(car group-art
) group-art
(cdr group-art
)
1524 (or (intern-soft gname groups
)
1525 (nnmaildir-request-create-group gname
)
1526 (throw 'return nil
)) ;; not that nnmail bothers to check :(
1527 (unless (nnmaildir-request-accept-article gname
)
1528 (throw 'return nil
))
1529 (setq nnmaildir--file
(nnmaildir--srv-dir nnmaildir--cur-server
)
1530 nnmaildir--file
(nnmaildir--srvgrp-dir nnmaildir--file gname
)
1531 x
(nnmaildir--prepare nil gname
)
1532 x
(nnmaildir--grp-nlist x
)
1534 nnmaildir--file
(concat nnmaildir--file
1535 (nnmaildir--art-prefix x
)
1536 (nnmaildir--art-suffix x
)))
1540 (setq gname
(car ga
))
1541 (and (or (intern-soft gname groups
)
1542 (nnmaildir-request-create-group gname
))
1543 (nnmaildir-request-accept-article gname
)
1547 (defun nnmaildir-active-number (_gname)
1550 (declare-function gnus-group-mark-article-read
"gnus-group" (group article
))
1552 (defun nnmaildir-request-expire-articles (ranges &optional gname server force
)
1553 (let ((no-force (not force
))
1554 (group (nnmaildir--prepare server gname
))
1555 pgname time boundary bound-iter high low target dir nlist
1556 didnt nnmaildir--file nnmaildir-article-file-name
1560 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1561 (if gname
(concat "No such group: " gname
) "No current group"))
1562 (throw 'return
(gnus-uncompress-range ranges
)))
1563 (setq gname
(nnmaildir--grp-name group
)
1564 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
))
1565 (if (nnmaildir--param pgname
'read-only
)
1566 (throw 'return
(gnus-uncompress-range ranges
)))
1567 (setq time
(nnmaildir--param pgname
'expire-age
))
1569 (setq time
(or (and nnmail-expiry-wait-function
1570 (funcall nnmail-expiry-wait-function gname
))
1571 nnmail-expiry-wait
))
1572 (if (eq time
'immediate
)
1575 (setq time
(round (* time
86400))))))
1577 (unless (integerp time
) ;; handle 'never
1578 (throw 'return
(gnus-uncompress-range ranges
)))
1579 (setq boundary
(current-time)
1580 high
(- (car boundary
) (/ time
65536))
1581 low
(- (cadr boundary
) (% time
65536)))
1583 (setq low
(+ low
65536)
1585 (setcar (cdr boundary
) low
)
1586 (setcar boundary high
))
1587 (setq dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1588 dir
(nnmaildir--srvgrp-dir dir gname
)
1589 dir
(nnmaildir--cur dir
)
1590 nlist
(nnmaildir--grp-nlist group
)
1591 ranges
(reverse ranges
))
1592 (nnmaildir--with-move-buffer
1593 (nnmaildir--nlist-iterate
1596 (setq nnmaildir--file
(nnmaildir--art-prefix article
)
1597 nnmaildir--file
(concat dir nnmaildir--file
1598 (nnmaildir--art-suffix article
))
1599 time
(file-attributes nnmaildir--file
))
1602 (nnmaildir--expired-article group article
))
1605 (setq time
(nth 5 time
)
1606 bound-iter boundary
)
1607 (while (and bound-iter time
1608 (= (car bound-iter
) (car time
)))
1609 (setq bound-iter
(cdr bound-iter
)
1611 (and bound-iter time
1612 (car-less-than-car bound-iter time
))))
1613 (setq didnt
(cons (nnmaildir--art-num article
) didnt
)))
1615 (setq nnmaildir-article-file-name nnmaildir--file
1616 target
(if force nil
1619 (nnmaildir--param pgname
'expire-group
)))))
1620 (when (and (stringp target
)
1621 (not (string-equal target pgname
))) ;; Move it.
1623 (nnheader-insert-file-contents nnmaildir--file
)
1624 (let ((group-art (gnus-request-accept-article
1625 target nil nil
'no-encode
)))
1626 (when (consp group-art
)
1627 ;; Maybe also copy: dormant forward reply save tick
1628 ;; (gnus-add-mark? gnus-request-set-mark?)
1629 (gnus-group-mark-article-read target
(cdr group-art
)))))
1630 (if (equal target pgname
)
1632 (setq didnt
(cons (nnmaildir--art-num article
) didnt
))
1633 (nnmaildir--unlink nnmaildir--file
)
1634 (nnmaildir--expired-article group article
))))))
1638 (defvar nnmaildir--article
)
1640 (defun nnmaildir-request-set-mark (gname actions
&optional server
)
1641 (let* ((group (nnmaildir--prepare server gname
))
1642 (curdir (nnmaildir--cur
1643 (nnmaildir--srvgrp-dir
1644 (nnmaildir--srv-dir nnmaildir--cur-server
)
1646 (coding-system-for-write nnheader-file-coding-system
)
1647 (buffer-file-coding-system nil
)
1648 (file-coding-system-alist nil
)
1650 ranges all-marks todo-marks mdir mfile
1651 pgname ls permarkfile deactivate-mark
1654 (let ((prefix (nnmaildir--art-prefix nnmaildir--article
))
1655 (suffix (nnmaildir--art-suffix nnmaildir--article
))
1656 (flag (nnmaildir--mark-to-flag mark
)))
1658 ;; If this mark corresponds to a flag, remove the flag from
1660 (nnmaildir--article-set-flags
1661 nnmaildir--article
(nnmaildir--remove-flag flag suffix
)
1663 ;; We still want to delete the hardlink in the marks dir if
1664 ;; present, regardless of whether this mark has a maildir flag or
1665 ;; not, to avoid getting out of sync.
1666 (setq mfile
(nnmaildir--subdir marksdir
(symbol-name mark
))
1667 mfile
(concat mfile prefix
))
1668 (nnmaildir--unlink mfile
))))
1669 (del-action (lambda (article)
1670 (let ((nnmaildir--article article
))
1671 (mapcar del-mark todo-marks
))))
1676 (let ((prefix (nnmaildir--art-prefix article
))
1677 (suffix (nnmaildir--art-suffix article
))
1678 (flag (nnmaildir--mark-to-flag mark
)))
1680 ;; If there is a corresponding maildir flag, just rename
1682 (nnmaildir--article-set-flags
1683 article
(nnmaildir--add-flag flag suffix
) curdir
)
1684 ;; Otherwise, use nnmaildir-specific marks dir.
1685 (setq mdir
(nnmaildir--subdir marksdir
(symbol-name mark
))
1686 permarkfile
(concat mdir
":")
1687 mfile
(concat mdir prefix
))
1688 (nnmaildir--condcase err
(add-name-to-file permarkfile mfile
)
1690 ((nnmaildir--eexist-p err
))
1691 ((nnmaildir--enoent-p err
)
1692 (nnmaildir--mkdir mdir
)
1693 (nnmaildir--mkfile permarkfile
)
1694 (add-name-to-file permarkfile mfile
))
1695 ((nnmaildir--emlink-p err
)
1696 (let ((permarkfilenew (concat permarkfile
"{new}")))
1697 (nnmaildir--mkfile permarkfilenew
)
1698 (rename-file permarkfilenew permarkfile
'replace
)
1699 (add-name-to-file permarkfile mfile
)))
1700 (t (signal (car err
) (cdr err
))))))))
1702 (set-action (lambda (article)
1703 (funcall add-action article
)
1704 (let ((nnmaildir--article article
))
1705 (mapcar (lambda (mark)
1706 (unless (memq mark todo-marks
)
1707 (funcall del-mark mark
)))
1711 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1712 (concat "No such group: " gname
))
1713 (dolist (action actions
)
1714 (setq ranges
(gnus-range-add ranges
(car action
))))
1715 (throw 'return ranges
))
1716 (setq nlist
(nnmaildir--grp-nlist group
)
1717 marksdir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1718 marksdir
(nnmaildir--srvgrp-dir marksdir gname
)
1719 marksdir
(nnmaildir--nndir marksdir
)
1720 marksdir
(nnmaildir--marks-dir marksdir
)
1721 gname
(nnmaildir--grp-name group
)
1722 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1723 ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
)
1724 all-marks
(funcall ls marksdir nil
"\\`[^.]" 'nosort
)
1725 all-marks
(gnus-delete-duplicates
1726 ;; get mark names from mark dirs and from flag
1729 (mapcar 'cdr nnmaildir-flag-mark-mapping
)
1730 (mapcar 'intern all-marks
))))
1731 (dolist (action actions
)
1732 (setq ranges
(car action
)
1733 todo-marks
(caddr action
))
1734 (dolist (mark todo-marks
)
1735 (pushnew mark all-marks
:test
#'equal
))
1736 (if (numberp (cdr ranges
)) (setq ranges
(list ranges
)))
1737 (nnmaildir--nlist-iterate nlist ranges
1738 (cond ((eq 'del
(cadr action
)) del-action
)
1739 ((eq 'add
(cadr action
)) add-action
)
1740 ((eq 'set
(cadr action
)) set-action
))))
1743 (defun nnmaildir-close-group (gname &optional server
)
1744 (let ((group (nnmaildir--prepare server gname
))
1745 pgname ls dir msgdir files flist dirs
)
1748 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1749 (concat "No such group: " gname
))
1751 (setq pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1752 ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
)
1753 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1754 dir
(nnmaildir--srvgrp-dir dir gname
)
1755 msgdir
(if (nnmaildir--param pgname
'read-only
)
1756 (nnmaildir--new dir
) (nnmaildir--cur dir
))
1757 dir
(nnmaildir--nndir dir
)
1758 dirs
(cons (nnmaildir--nov-dir dir
)
1759 (funcall ls
(nnmaildir--marks-dir dir
) 'full
"\\`[^.]"
1763 (cons dir
(funcall ls dir nil
"\\`[^.]" 'nosort
)))
1765 files
(funcall ls msgdir nil
"\\`[^.]" 'nosort
)
1766 flist
(nnmaildir--up2-1 (length files
))
1767 flist
(make-vector flist
0))
1769 (dolist (file files
)
1770 (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file
)
1771 (intern (match-string 1 file
) flist
)))
1773 (setq files
(cdr dir
)
1774 dir
(file-name-as-directory (car dir
)))
1775 (dolist (file files
)
1776 (unless (or (intern-soft file flist
) (string= file
":"))
1777 (setq file
(concat dir file
))
1778 (delete-file file
))))
1781 (defun nnmaildir-close-server (&optional server
)
1782 (defvar flist
) (defvar ls
) (defvar dirs
) (defvar dir
)
1783 (defvar files
) (defvar file
) (defvar x
)
1784 (let (flist ls dirs dir files file x
)
1785 (nnmaildir--prepare server nil
)
1786 (when nnmaildir--cur-server
1787 (setq server nnmaildir--cur-server
1788 nnmaildir--cur-server nil
)
1789 (unintern (nnmaildir--srv-address server
) nnmaildir--servers
)))
1792 (defun nnmaildir-request-close ()
1793 (let (servers buffer
)
1794 (mapatoms (lambda (server)
1795 (setq servers
(cons (symbol-name server
) servers
)))
1797 (mapc 'nnmaildir-close-server servers
)
1798 (setq buffer
(get-buffer " *nnmaildir work*"))
1799 (if buffer
(kill-buffer buffer
))
1800 (setq buffer
(get-buffer " *nnmaildir nov*"))
1801 (if buffer
(kill-buffer buffer
))
1802 (setq buffer
(get-buffer " *nnmaildir move*"))
1803 (if buffer
(kill-buffer buffer
)))
1806 (provide 'nnmaildir
)
1809 ;; indent-tabs-mode: t
1813 ;;; nnmaildir.el ends here
