1 ;;; nnmaildir.el --- maildir backend for Gnus
3 ;; This file is in the public domain.
5 ;; Author: Paul Jarc <prj@po.cwru.edu>
7 ;; This file is part of GNU Emacs.
9 ;; GNU Emacs is free software: you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation, either version 3 of the License, or
12 ;; (at your option) any later version.
14 ;; GNU Emacs is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 ;; Maildir format is documented at <URL:http://cr.yp.to/proto/maildir.html>
25 ;; and in the maildir(5) man page from qmail (available at
26 ;; <URL:http://www.qmail.org/man/man5/maildir.html>). nnmaildir also stores
27 ;; extra information in the .nnmaildir/ directory within a maildir.
29 ;; Some goals of nnmaildir:
30 ;; * Everything Just Works, and correctly. E.g., NOV data is automatically
31 ;; regenerated when stale; no need for manually running
32 ;; *-generate-nov-databases.
33 ;; * Perfect reliability: [C-g] will never corrupt its data in memory, and
34 ;; SIGKILL will never corrupt its data in the filesystem.
35 ;; * Allow concurrent operation as much as possible. If files change out
36 ;; from under us, adapt to the changes or degrade gracefully.
37 ;; * We use the filesystem as a database, so that, e.g., it's easy to
38 ;; manipulate marks from outside Gnus.
39 ;; * All information about a group is stored in the maildir, for easy backup,
40 ;; copying, restoring, etc.
43 ;; * When moving an article for expiry, copy all the marks except 'expire
44 ;; from the original article.
45 ;; * Add a hook for when moving messages from new/ to cur/, to support
46 ;; nnmail's duplicate detection.
47 ;; * Improve generated Xrefs, so crossposts are detectable.
48 ;; * Improve code readability.
52 ;; eval this before editing
54 (put 'nnmaildir--with-nntp-buffer
'lisp-indent-function
0)
55 (put 'nnmaildir--with-work-buffer
'lisp-indent-function
0)
56 (put 'nnmaildir--with-nov-buffer
'lisp-indent-function
0)
57 (put 'nnmaildir--with-move-buffer
'lisp-indent-function
0)
58 (put 'nnmaildir--condcase
'lisp-indent-function
2)
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 (and (eq (car err
) 'file-error
)
375 (string= (downcase (caddr err
)) "no such file or directory")))
377 (defun nnmaildir--eexist-p (err)
378 (eq (car err
) 'file-already-exists
))
380 (defun nnmaildir--new-number (nndir)
381 "Allocate a new article number by atomically creating a file under NNDIR."
382 (let ((numdir (nnmaildir--num-dir nndir
))
385 number-link previous-number-link path-open path-link ino-open
)
386 (nnmaildir--mkdir numdir
)
389 (setq path-open
(concat numdir
(number-to-string number-open
)))
390 (if (not make-new-file
)
391 (setq previous-number-link number-link
)
392 (nnmaildir--mkfile path-open
)
393 ;; If Emacs had O_CREAT|O_EXCL, we could return number-open here.
394 (setq make-new-file nil
395 previous-number-link
0))
396 (let* ((attr (file-attributes path-open
))
397 (nlink (nth 1 attr
)))
398 (setq ino-open
(nth 10 attr
)
399 number-link
(+ number-open nlink
))
400 (if (or (< nlink
1) (< number-link nlink
))
401 (signal 'error
'("Arithmetic overflow"))))
402 (if (= number-link previous-number-link
)
403 ;; We've already tried this number, in the previous loop iteration,
405 (signal 'error
`("Corrupt internal nnmaildir data" ,path-open
)))
406 (setq path-link
(concat numdir
(number-to-string number-link
)))
407 (nnmaildir--condcase err
409 (add-name-to-file path-open path-link
)
410 (throw 'return number-link
))
412 ((nnmaildir--emlink-p err
)
413 (setq make-new-file t
414 number-open number-link
))
415 ((nnmaildir--eexist-p err
)
416 (let ((attr (file-attributes path-link
)))
417 (unless (equal (nth 10 attr
) ino-open
)
418 (setq number-open number-link
420 (t (signal (car err
) (cdr err
)))))))))
422 (defun nnmaildir--update-nov (server group article
)
423 (let ((nnheader-file-coding-system 'binary
)
424 (srv-dir (nnmaildir--srv-dir server
))
425 (storage-version 1) ;; [version article-number msgid [...nov...]]
426 dir gname pgname msgdir prefix suffix file attr mtime novdir novfile
427 nov msgid nov-beg nov-mid nov-end field val old-extra num
430 (setq gname
(nnmaildir--grp-name group
)
431 pgname
(nnmaildir--pgname server gname
)
432 dir
(nnmaildir--srvgrp-dir srv-dir gname
)
433 msgdir
(if (nnmaildir--param pgname
'read-only
)
434 (nnmaildir--new dir
) (nnmaildir--cur dir
))
435 prefix
(nnmaildir--art-prefix article
)
436 suffix
(nnmaildir--art-suffix article
)
437 file
(concat msgdir prefix suffix
)
438 attr
(file-attributes file
))
440 (nnmaildir--expired-article group article
)
442 (setq mtime
(nth 5 attr
)
444 nov
(nnmaildir--art-nov article
)
445 dir
(nnmaildir--nndir dir
)
446 novdir
(nnmaildir--nov-dir dir
)
447 novfile
(concat novdir prefix
))
448 (unless (equal nnmaildir--extra nnmail-extra-headers
)
449 (setq nnmaildir--extra
(copy-sequence nnmail-extra-headers
)))
450 (nnmaildir--with-nov-buffer
451 ;; First we'll check for already-parsed NOV data.
452 (cond ((not (file-exists-p novfile
))
453 ;; The NOV file doesn't exist; we have to parse the message.
456 ;; The file exists, but the data isn't in memory; read the file.
458 (nnheader-insert-file-contents novfile
)
459 (setq nov
(read (current-buffer)))
460 (if (not (and (vectorp nov
)
462 (equal storage-version
(aref nov
0))))
463 ;; This NOV data seems to be in the wrong format.
465 (unless (nnmaildir--art-num article
)
466 (setf (nnmaildir--art-num article
) (aref nov
1)))
467 (unless (nnmaildir--art-msgid article
)
468 (setf (nnmaildir--art-msgid article
) (aref nov
2)))
469 (setq nov
(aref nov
3)))))
470 ;; Now check whether the already-parsed data (if we have any) is
471 ;; usable: if the message has been edited or if nnmail-extra-headers
472 ;; has been augmented since this data was parsed from the message,
473 ;; then we have to reparse. Otherwise it's up-to-date.
474 (when (and nov
(equal mtime
(nnmaildir--nov-get-mtime nov
)))
475 ;; The timestamp matches. Now check nnmail-extra-headers.
476 (setq old-extra
(nnmaildir--nov-get-extra nov
))
477 (when (equal nnmaildir--extra old-extra
) ;; common case
478 ;; Save memory; use a single copy of the list value.
479 (nnmaildir--nov-set-extra nov nnmaildir--extra
)
481 ;; They're not equal, but maybe the new is a subset of the old.
482 (if (null nnmaildir--extra
)
483 ;; The empty set is a subset of every set.
485 (if (not (memq nil
(mapcar (lambda (e) (memq e old-extra
))
487 (throw 'return nov
)))
488 ;; Parse the NOV data out of the message.
490 (nnheader-insert-file-contents file
)
492 (goto-char (point-min))
494 (if (search-forward "\n\n" nil
'noerror
)
496 (setq nov-mid
(count-lines (point) (point-max)))
497 (narrow-to-region (point-min) (1- (point))))
499 (goto-char (point-min))
501 (setq nov
(nnheader-parse-naked-head)
502 field
(or (mail-header-lines nov
) 0)))
503 (unless (or (zerop field
) (nnmaildir--param pgname
'distrust-Lines
:))
504 (setq nov-mid field
))
505 (setq nov-mid
(number-to-string nov-mid
)
506 nov-mid
(concat (number-to-string attr
) "\t" nov-mid
))
508 (setq field
(or (mail-header-references nov
) ""))
509 (nnmaildir--tab-to-space field
)
510 (setq nov-mid
(concat field
"\t" nov-mid
)
512 (lambda (f) (nnmaildir--tab-to-space (or f
"")))
513 (list (mail-header-subject nov
)
514 (mail-header-from nov
)
515 (mail-header-date nov
)) "\t")
518 (setq field
(symbol-name (car extra
))
520 (nnmaildir--tab-to-space field
)
521 (nnmaildir--tab-to-space val
)
522 (concat field
": " val
))
523 (mail-header-extra nov
) "\t")))
524 (setq msgid
(mail-header-id nov
))
525 (if (or (null msgid
) (nnheader-fake-message-id-p msgid
))
526 (setq msgid
(concat "<" prefix
"@nnmaildir>")))
527 (nnmaildir--tab-to-space msgid
)
528 ;; The data is parsed; create an nnmaildir NOV structure.
529 (setq nov
(nnmaildir--nov-new nov-beg nov-mid nov-end mtime
531 num
(nnmaildir--art-num article
))
533 (setq num
(nnmaildir--new-number dir
))
534 (setf (nnmaildir--art-num article
) num
))
535 ;; Store this new NOV data in a file
537 (prin1 (vector storage-version num msgid nov
) (current-buffer))
538 (setq file
(concat novfile
":"))
539 (nnmaildir--unlink file
)
540 (write-region (point-min) (point-max) file nil
'no-message nil
542 (rename-file file novfile
'replace
)
543 (setf (nnmaildir--art-msgid article
) msgid
)
546 (defun nnmaildir--cache-nov (group article nov
)
547 (let ((cache (nnmaildir--grp-cache group
))
548 (index (nnmaildir--grp-index group
))
550 (unless (nnmaildir--art-nov article
)
551 (setq goner
(aref cache index
))
552 (if goner
(setf (nnmaildir--art-nov goner
) nil
))
553 (aset cache index article
)
554 (setf (nnmaildir--grp-index group
) (%
(1+ index
) (length cache
))))
555 (setf (nnmaildir--art-nov article
) nov
)))
557 (defun nnmaildir--grp-add-art (server group article
)
558 (let ((nov (nnmaildir--update-nov server group article
))
559 count num min nlist nlist-cdr insert-nlist
)
561 (setq count
(1+ (nnmaildir--grp-count group
))
562 num
(nnmaildir--art-num article
)
563 min
(if (= count
1) num
564 (min num
(nnmaildir--grp-min group
)))
565 nlist
(nnmaildir--grp-nlist group
))
566 (if (or (null nlist
) (> num
(caar nlist
)))
567 (setq nlist
(cons (cons num article
) nlist
))
569 nlist-cdr
(cdr nlist
))
570 (while (and nlist-cdr
(< num
(caar nlist-cdr
)))
571 (setq nlist nlist-cdr
572 nlist-cdr
(cdr nlist
))))
573 (let ((inhibit-quit t
))
574 (setf (nnmaildir--grp-count group
) count
)
575 (setf (nnmaildir--grp-min group
) min
)
577 (setcdr nlist
(cons (cons num article
) nlist-cdr
))
578 (setf (nnmaildir--grp-nlist group
) nlist
))
579 (set (intern (nnmaildir--art-prefix article
)
580 (nnmaildir--grp-flist group
))
582 (set (intern (nnmaildir--art-msgid article
)
583 (nnmaildir--grp-mlist group
))
585 (set (intern (nnmaildir--grp-name group
)
586 (nnmaildir--srv-groups server
))
588 (nnmaildir--cache-nov group article nov
)
591 (defun nnmaildir--group-ls (server pgname
)
592 (or (nnmaildir--param pgname
'directory-files
)
593 (nnmaildir--srv-ls server
)))
595 (defun nnmaildir-article-number-to-file-name
596 (number group-name server-address-string
)
597 (let ((group (nnmaildir--prepare server-address-string group-name
))
601 ;; The given group or server does not exist.
603 (setq article
(nnmaildir--nlist-art group number
))
605 ;; The given article number does not exist in this group.
607 (setq pgname
(nnmaildir--pgname nnmaildir--cur-server group-name
)
608 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
609 dir
(nnmaildir--srvgrp-dir dir group-name
)
610 dir
(if (nnmaildir--param pgname
'read-only
)
611 (nnmaildir--new dir
) (nnmaildir--cur dir
)))
612 (concat dir
(nnmaildir--art-prefix article
)
613 (nnmaildir--art-suffix article
)))))
615 (defun nnmaildir-article-number-to-base-name
616 (number group-name server-address-string
)
617 (let ((x (nnmaildir--prepare server-address-string group-name
)))
619 (setq x
(nnmaildir--nlist-art x number
))
620 (and x
(cons (nnmaildir--art-prefix x
)
621 (nnmaildir--art-suffix x
))))))
623 (defun nnmaildir-base-name-to-article-number
624 (base-name group-name server-address-string
)
625 (let ((x (nnmaildir--prepare server-address-string group-name
)))
627 (setq x
(nnmaildir--grp-flist x
)
628 x
(nnmaildir--flist-art x base-name
))
629 (and x
(nnmaildir--art-num x
)))))
631 (defun nnmaildir--nlist-iterate (nlist ranges func
)
632 (let (entry high low nlist2
)
634 (setq ranges
`((1 .
,(caar nlist
)))))
636 (setq entry
(car ranges
) ranges
(cdr ranges
))
637 (while (and ranges
(eq entry
(car ranges
)))
638 (setq ranges
(cdr ranges
))) ;; skip duplicates
642 (setq low
(car entry
)
644 (setq nlist2 nlist
) ;; Don't assume any sorting of ranges
647 (if (<= (caar nlist2
) high
) (throw 'iterate-loop nil
))
648 (setq nlist2
(cdr nlist2
))))
651 (setq entry
(car nlist2
) nlist2
(cdr nlist2
))
652 (if (< (car entry
) low
) (throw 'iterate-loop nil
))
653 (funcall func
(cdr entry
)))))))
655 (defun nnmaildir--up2-1 (n)
656 (if (zerop n
) 1 (1- (lsh 1 (1+ (logb n
))))))
658 (defun nnmaildir--system-name ()
659 (replace-regexp-in-string
661 (replace-regexp-in-string
663 (replace-regexp-in-string "\\\\" "\\134" (system-name) nil
'literal
)
667 (defun nnmaildir-request-type (_group &optional _article
)
670 (defun nnmaildir-status-message (&optional server
)
671 (nnmaildir--prepare server nil
)
672 (nnmaildir--srv-error nnmaildir--cur-server
))
674 (defun nnmaildir-server-opened (&optional server
)
675 (and nnmaildir--cur-server
677 (string-equal server
(nnmaildir--srv-address nnmaildir--cur-server
))
679 (nnmaildir--srv-groups nnmaildir--cur-server
)
682 (defun nnmaildir-open-server (server &optional defs
)
686 (setq server
(intern-soft x nnmaildir--servers
))
688 (and (setq server
(symbol-value server
))
689 (nnmaildir--srv-groups server
)
690 (setq nnmaildir--cur-server server
)
692 (setq server
(make-nnmaildir--srv :address x
))
693 (let ((inhibit-quit t
))
694 (set (intern x nnmaildir--servers
) server
)))
695 (setq dir
(assq 'directory defs
))
697 (setf (nnmaildir--srv-error server
)
698 "You must set \"directory\" in the select method")
702 dir
(expand-file-name dir
)
703 dir
(file-name-as-directory dir
))
704 (unless (file-exists-p dir
)
705 (setf (nnmaildir--srv-error server
) (concat "No such directory: " dir
))
707 (setf (nnmaildir--srv-dir server
) dir
)
708 (setq x
(assq 'directory-files defs
))
710 (setq x
(if nnheader-directory-files-is-safe
'directory-files
711 'nnheader-directory-files-safe
))
713 (unless (functionp x
)
714 (setf (nnmaildir--srv-error server
)
715 (concat "Not a function: " (prin1-to-string x
)))
716 (throw 'return nil
)))
717 (setf (nnmaildir--srv-ls server
) x
)
718 (setq size
(length (funcall x dir nil
"\\`[^.]" 'nosort
))
719 size
(nnmaildir--up2-1 size
))
720 (and (setq x
(assq 'get-new-mail defs
))
723 (setf (nnmaildir--srv-gnm server
) t
)
725 (setq x
(assq 'target-prefix defs
))
730 (setf (nnmaildir--srv-target-prefix server
) x
))
731 (setq x
(assq 'create-directory defs
))
736 x
(file-name-as-directory x
))
737 (setf (nnmaildir--srv-target-prefix server
) x
))
738 (setf (nnmaildir--srv-target-prefix server
) "")))
739 (setf (nnmaildir--srv-groups server
) (make-vector size
0))
740 (setq nnmaildir--cur-server server
)
743 (defun nnmaildir--parse-filename (file)
744 (let ((prefix (car file
))
746 (if (string-match "\\`\\([0-9]+\\)\\(\\..*\\)\\'" prefix
)
748 (setq timestamp
(concat "0000" (match-string 1 prefix
))
749 len
(- (length timestamp
) 4))
750 (vector (string-to-number (substring timestamp
0 len
))
751 (string-to-number (substring timestamp len
))
752 (match-string 2 prefix
)
756 (defun nnmaildir--sort-files (a b
)
759 (throw 'return
(and (consp b
) (string-lessp (car a
) (car b
)))))
760 (if (consp b
) (throw 'return t
))
761 (if (< (aref a
0) (aref b
0)) (throw 'return t
))
762 (if (> (aref a
0) (aref b
0)) (throw 'return nil
))
763 (if (< (aref a
1) (aref b
1)) (throw 'return t
))
764 (if (> (aref a
1) (aref b
1)) (throw 'return nil
))
765 (string-lessp (aref a
2) (aref b
2))))
767 (defun nnmaildir--scan (gname scan-msgs groups _method srv-dir srv-ls
)
769 (let ((36h-ago (- (car (current-time)) 2))
770 absdir nndir tdir ndir cdir nattr cattr isnew pgname read-only ls
771 files num dir flist group x
)
772 (setq absdir
(nnmaildir--srvgrp-dir srv-dir gname
)
773 nndir
(nnmaildir--nndir absdir
))
774 (unless (file-exists-p absdir
)
775 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
776 (concat "No such directory: " absdir
))
778 (setq tdir
(nnmaildir--tmp absdir
)
779 ndir
(nnmaildir--new absdir
)
780 cdir
(nnmaildir--cur absdir
)
781 nattr
(file-attributes ndir
)
782 cattr
(file-attributes cdir
))
783 (unless (and (file-exists-p tdir
) nattr cattr
)
784 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
785 (concat "Not a maildir: " absdir
))
787 (setq group
(nnmaildir--prepare nil gname
)
788 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
))
792 group
(make-nnmaildir--grp :name gname
:index
0))
793 (nnmaildir--mkdir nndir
)
794 (nnmaildir--mkdir (nnmaildir--nov-dir nndir
))
795 (nnmaildir--mkdir (nnmaildir--marks-dir nndir
)))
796 (setq read-only
(nnmaildir--param pgname
'read-only
)
797 ls
(or (nnmaildir--param pgname
'directory-files
) srv-ls
))
799 (setq x
(nth 11 (file-attributes tdir
)))
800 (unless (and (equal x
(nth 11 nattr
)) (equal x
(nth 11 cattr
)))
801 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
802 (concat "Maildir spans filesystems: " absdir
))
804 (dolist (file (funcall ls tdir
'full
"\\`[^.]" 'nosort
))
805 (setq x
(file-attributes file
))
806 (if (or (> (cadr x
) 1) (< (car (nth 4 x
)) 36h-ago
))
807 (delete-file file
))))
811 (setq nattr
(nth 5 nattr
))
812 (if (equal nattr
(nnmaildir--grp-new group
))
814 (if read-only
(setq dir
(and (or isnew nattr
) ndir
))
815 (when (or isnew nattr
)
816 (dolist (file (funcall ls ndir nil
"\\`[^.]" 'nosort
))
817 (setq x
(concat ndir file
))
818 (and (time-less-p (nth 5 (file-attributes x
)) (current-time))
819 (rename-file x
(concat cdir
(nnmaildir--ensure-suffix file
)))))
820 (setf (nnmaildir--grp-new group
) nattr
))
821 (setq cattr
(nth 5 (file-attributes cdir
)))
822 (if (equal cattr
(nnmaildir--grp-cur group
))
824 (setq dir
(and (or isnew cattr
) cdir
)))
825 (unless dir
(throw 'return t
))
826 (setq files
(funcall ls dir nil
"\\`[^.]" 'nosort
)
827 files
(save-match-data
830 (string-match "\\`\\([^:]*\\)\\(\\(:.*\\)?\\)\\'" f
)
831 (cons (match-string 1 f
) (match-string 2 f
)))
834 (setq num
(nnmaildir--up2-1 (length files
)))
835 (setf (nnmaildir--grp-flist group
) (make-vector num
0))
836 (setf (nnmaildir--grp-mlist group
) (make-vector num
0))
837 (setf (nnmaildir--grp-mmth group
) (make-vector 1 0))
838 (setq num
(nnmaildir--param pgname
'nov-cache-size
))
839 (if (numberp num
) (if (< num
1) (setq num
1))
841 cdir
(nnmaildir--marks-dir nndir
)
842 ndir
(nnmaildir--subdir cdir
"tick")
843 cdir
(nnmaildir--subdir cdir
"read"))
844 (dolist (prefix-suffix files
)
845 (let ((prefix (car prefix-suffix
))
846 (suffix (cdr prefix-suffix
)))
847 ;; increase num for each unread or ticked article
849 ;; first look for marks in suffix, if it's valid...
850 (when (and (stringp suffix
)
851 (string-prefix-p ":2," suffix
))
854 (string (nnmaildir--mark-to-flag 'read
)) suffix
))
856 (string (nnmaildir--mark-to-flag 'tick
)) suffix
)))
857 ;; then look in marks directories
858 (not (file-exists-p (concat cdir prefix
)))
859 (file-exists-p (concat ndir prefix
)))
861 (setf (nnmaildir--grp-cache group
) (make-vector num nil
))
862 (let ((inhibit-quit t
))
863 (set (intern gname groups
) group
))
864 (or scan-msgs
(throw 'return t
)))
865 (setq flist
(nnmaildir--grp-flist group
)
868 (and (null (nnmaildir--flist-art flist
(car file
)))
871 files
(delq nil files
)
872 files
(mapcar 'nnmaildir--parse-filename files
)
873 files
(sort files
'nnmaildir--sort-files
))
875 (setq file
(if (consp file
) file
(aref file
3))
876 x
(make-nnmaildir--art :prefix
(car file
) :suffix
(cdr file
)))
877 (nnmaildir--grp-add-art nnmaildir--cur-server group x
))
878 (if read-only
(setf (nnmaildir--grp-new group
) nattr
)
879 (setf (nnmaildir--grp-cur group
) cattr
)))
882 (defvar nnmaildir-get-new-mail
)
883 (defvar nnmaildir-group-alist
)
884 (defvar nnmaildir-active-file
)
886 (defun nnmaildir-request-scan (&optional scan-group server
)
887 (let ((coding-system-for-write nnheader-file-coding-system
)
888 (buffer-file-coding-system nil
)
889 (file-coding-system-alist nil
)
890 (nnmaildir-get-new-mail t
)
891 (nnmaildir-group-alist nil
)
892 (nnmaildir-active-file nil
)
893 x srv-ls srv-dir method groups target-prefix dirs seen
895 (nnmaildir--prepare server nil
)
896 (setq srv-ls
(nnmaildir--srv-ls nnmaildir--cur-server
)
897 srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
898 method
(nnmaildir--srv-method nnmaildir--cur-server
)
899 groups
(nnmaildir--srv-groups nnmaildir--cur-server
)
900 target-prefix
(nnmaildir--srv-target-prefix nnmaildir--cur-server
))
901 (nnmaildir--with-work-buffer
903 (if (stringp scan-group
)
904 (if (nnmaildir--scan scan-group t groups method srv-dir srv-ls
)
905 (if (nnmaildir--srv-gnm nnmaildir--cur-server
)
906 (nnmail-get-new-mail 'nnmaildir nil nil scan-group
))
907 (unintern scan-group groups
))
908 (setq x
(nth 5 (file-attributes srv-dir
))
909 scan-group
(null scan-group
))
910 (if (equal x
(nnmaildir--srv-mtime nnmaildir--cur-server
))
912 (mapatoms (lambda (sym)
913 (nnmaildir--scan (symbol-name sym
) t groups
914 method srv-dir srv-ls
))
916 (setq dirs
(funcall srv-ls srv-dir nil
"\\`[^.]" 'nosort
)
917 dirs
(if (zerop (length target-prefix
))
921 (and (>= (length dir
) (length target-prefix
))
922 (string= (substring dir
0
923 (length target-prefix
))
926 seen
(nnmaildir--up2-1 (length dirs
))
927 seen
(make-vector seen
0))
928 (dolist (grp-dir dirs
)
929 (if (nnmaildir--scan grp-dir scan-group groups method srv-dir
931 (intern grp-dir seen
)))
933 (mapatoms (lambda (group)
934 (setq group
(symbol-name group
))
935 (unless (intern-soft group seen
)
936 (setq x
(cons group x
))))
939 (unintern grp groups
))
940 (setf (nnmaildir--srv-mtime nnmaildir--cur-server
)
941 (nth 5 (file-attributes srv-dir
))))
943 (nnmaildir--srv-gnm nnmaildir--cur-server
)
944 (nnmail-get-new-mail 'nnmaildir nil nil
))))))
947 (defun nnmaildir-request-list (&optional server
)
948 (nnmaildir-request-scan 'find-new-groups server
)
949 (let (pgname ro deactivate-mark
)
950 (nnmaildir--prepare server nil
)
951 (nnmaildir--with-nntp-buffer
953 (mapatoms (lambda (group)
954 (setq pgname
(symbol-name group
)
955 pgname
(nnmaildir--pgname nnmaildir--cur-server pgname
)
956 group
(symbol-value group
)
957 ro
(nnmaildir--param pgname
'read-only
))
958 (insert (replace-regexp-in-string
960 (nnmaildir--grp-name group
) nil t
)
962 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group
)
965 (princ (nnmaildir--grp-min group
) nntp-server-buffer
)
966 (insert " " (if ro
"n" "y") "\n"))
967 (nnmaildir--srv-groups nnmaildir--cur-server
))))
970 (defun nnmaildir-request-newgroups (_date &optional server
)
971 (nnmaildir-request-list server
))
973 (defun nnmaildir-retrieve-groups (groups &optional server
)
974 (let (group deactivate-mark
)
975 (nnmaildir--prepare server nil
)
976 (nnmaildir--with-nntp-buffer
978 (dolist (gname groups
)
979 (setq group
(nnmaildir--prepare nil gname
))
980 (if (null group
) (insert "411 no such news group\n")
982 (princ (nnmaildir--grp-count group
) nntp-server-buffer
)
984 (princ (nnmaildir--grp-min group
) nntp-server-buffer
)
986 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group
)
989 (replace-regexp-in-string " " "\\ " gname nil t
)
993 (defun nnmaildir-request-update-info (gname info
&optional server
)
994 (let* ((group (nnmaildir--prepare server gname
))
995 (curdir (nnmaildir--cur
996 (nnmaildir--srvgrp-dir
997 (nnmaildir--srv-dir nnmaildir--cur-server
) gname
)))
998 (curdir-mtime (nth 5 (file-attributes curdir
)))
999 pgname flist always-marks never-marks old-marks dir
1000 all-marks marks ranges markdir read ls
1001 old-mmth new-mmth mtime existing missing deactivate-mark
)
1004 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1005 (concat "No such group: " gname
))
1006 (throw 'return nil
))
1007 (setq gname
(nnmaildir--grp-name group
)
1008 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1009 flist
(nnmaildir--grp-flist group
))
1010 (when (zerop (nnmaildir--grp-count group
))
1011 (gnus-info-set-read info nil
)
1012 (gnus-info-set-marks info nil
'extend
)
1013 (throw 'return info
))
1014 (setq old-marks
(cons 'read
(gnus-info-read info
))
1015 old-marks
(cons old-marks
(gnus-info-marks info
))
1016 always-marks
(nnmaildir--param pgname
'always-marks
)
1017 never-marks
(nnmaildir--param pgname
'never-marks
)
1018 existing
(nnmaildir--grp-nlist group
)
1019 existing
(mapcar 'car existing
)
1020 existing
(nreverse existing
)
1021 existing
(gnus-compress-sequence existing
'always-list
)
1022 missing
(list (cons 1 (nnmaildir--group-maxnum
1023 nnmaildir--cur-server group
)))
1024 missing
(gnus-range-difference missing existing
)
1025 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1026 dir
(nnmaildir--srvgrp-dir dir gname
)
1027 dir
(nnmaildir--nndir dir
)
1028 dir
(nnmaildir--marks-dir dir
)
1029 ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
)
1030 all-marks
(gnus-delete-duplicates
1031 ;; get mark names from mark dirs and from flag
1034 (mapcar 'cdr nnmaildir-flag-mark-mapping
)
1035 (mapcar 'intern
(funcall ls dir nil
"\\`[^.]" 'nosort
))))
1036 new-mmth
(nnmaildir--up2-1 (length all-marks
))
1037 new-mmth
(make-vector new-mmth
0)
1038 old-mmth
(nnmaildir--grp-mmth group
))
1039 (dolist (mark all-marks
)
1040 (setq markdir
(nnmaildir--subdir dir
(symbol-name mark
))
1043 (if (memq mark never-marks
) (throw 'got-ranges nil
))
1044 (when (memq mark always-marks
)
1045 (setq ranges existing
)
1046 (throw 'got-ranges nil
))
1047 ;; Find the mtime for this mark. If this mark can be expressed as
1048 ;; a filename flag, get the later of the mtimes for markdir and
1049 ;; curdir, otherwise only the markdir counts.
1051 (let ((markdir-mtime (nth 5 (file-attributes markdir
))))
1053 ((null (nnmaildir--mark-to-flag mark
))
1055 ((null markdir-mtime
)
1057 ((null curdir-mtime
)
1058 ;; this should never happen...
1060 ((time-less-p markdir-mtime curdir-mtime
)
1064 (set (intern (symbol-name mark
) new-mmth
) mtime
)
1065 (when (equal mtime
(symbol-value (intern-soft (symbol-name mark
) old-mmth
)))
1066 (setq ranges
(assq mark old-marks
))
1067 (if ranges
(setq ranges
(cdr ranges
)))
1068 (throw 'got-ranges nil
))
1069 (let ((article-list nil
))
1070 ;; Consider the article marked if it either has the flag in the
1071 ;; filename, or is in the markdir. As you'd rarely remove a
1072 ;; flag/mark, this should avoid losing information in the most
1073 ;; common usage pattern.
1075 (let ((flag (nnmaildir--mark-to-flag mark
)))
1076 ;; If this mark has a corresponding maildir flag...
1079 (concat "\\`[^.].*:2,[A-Z]*" (string flag
))))
1080 ;; ...then find all files with that flag.
1081 (dolist (filename (funcall ls curdir nil regexp
'nosort
))
1082 (let* ((prefix (car (split-string filename
":2,")))
1083 (article (nnmaildir--flist-art flist prefix
)))
1085 (push (nnmaildir--art-num article
) article-list
)))))))
1086 ;; Also check Gnus-specific mark directory, if it exists.
1087 (when (file-directory-p markdir
)
1088 (dolist (prefix (funcall ls markdir nil
"\\`[^.]" 'nosort
))
1089 (let ((article (nnmaildir--flist-art flist prefix
)))
1091 (push (nnmaildir--art-num article
) article-list
))))))
1092 (setq ranges
(gnus-add-to-range ranges
(sort article-list
'<)))))
1093 (if (eq mark
'read
) (setq read ranges
)
1094 (if ranges
(setq marks
(cons (cons mark ranges
) marks
)))))
1095 (gnus-info-set-read info
(gnus-range-add read missing
))
1096 (gnus-info-set-marks info marks
'extend
)
1097 (setf (nnmaildir--grp-mmth group
) new-mmth
)
1100 (defun nnmaildir-request-group (gname &optional server fast _info
)
1101 (let ((group (nnmaildir--prepare server gname
))
1105 ;; (insert "411 no such news group\n")
1106 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1107 (concat "No such group: " gname
))
1108 (throw 'return nil
))
1109 (setf (nnmaildir--srv-curgrp nnmaildir--cur-server
) group
)
1110 (if fast
(throw 'return t
))
1111 (nnmaildir--with-nntp-buffer
1114 (princ (nnmaildir--grp-count group
) nntp-server-buffer
)
1116 (princ (nnmaildir--grp-min group
) nntp-server-buffer
)
1118 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group
)
1120 (insert " " (replace-regexp-in-string " " "\\ " gname nil t
) "\n")
1123 (defun nnmaildir-request-create-group (gname &optional server _args
)
1124 (nnmaildir--prepare server nil
)
1126 (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server
))
1128 (when (zerop (length gname
))
1129 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1130 "Invalid (empty) group name")
1131 (throw 'return nil
))
1132 (when (eq (aref "." 0) (aref gname
0))
1133 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1134 "Group names may not start with \".\"")
1135 (throw 'return nil
))
1136 (when (save-match-data (string-match "[\0/\t]" gname
))
1137 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1138 (concat "Invalid characters (null, tab, or /) in group name: "
1140 (throw 'return nil
))
1141 (setq groups
(nnmaildir--srv-groups nnmaildir--cur-server
))
1142 (when (intern-soft gname groups
)
1143 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1144 (concat "Group already exists: " gname
))
1145 (throw 'return nil
))
1146 (setq srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
))
1147 (if (file-name-absolute-p target-prefix
)
1148 (setq dir
(expand-file-name target-prefix
))
1150 dir
(file-truename dir
)
1151 dir
(concat dir target-prefix
)))
1152 (setq dir
(nnmaildir--subdir dir gname
))
1153 (nnmaildir--mkdir dir
)
1154 (nnmaildir--mkdir (nnmaildir--tmp dir
))
1155 (nnmaildir--mkdir (nnmaildir--new dir
))
1156 (nnmaildir--mkdir (nnmaildir--cur dir
))
1157 (unless (string= target-prefix
"")
1158 (make-symbolic-link (concat target-prefix gname
)
1159 (concat srv-dir gname
)))
1160 (nnmaildir-request-scan 'find-new-groups
))))
1162 (defun nnmaildir-request-rename-group (gname new-name
&optional server
)
1163 (let ((group (nnmaildir--prepare server gname
))
1164 (coding-system-for-write nnheader-file-coding-system
)
1165 (buffer-file-coding-system nil
)
1166 (file-coding-system-alist nil
)
1170 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1171 (concat "No such group: " gname
))
1172 (throw 'return nil
))
1173 (when (zerop (length new-name
))
1174 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1175 "Invalid (empty) group name")
1176 (throw 'return nil
))
1177 (when (eq (aref "." 0) (aref new-name
0))
1178 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1179 "Group names may not start with \".\"")
1180 (throw 'return nil
))
1181 (when (save-match-data (string-match "[\0/\t]" new-name
))
1182 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1183 (concat "Invalid characters (null, tab, or /) in group name: "
1185 (throw 'return nil
))
1186 (if (string-equal gname new-name
) (throw 'return t
))
1187 (when (intern-soft new-name
1188 (nnmaildir--srv-groups nnmaildir--cur-server
))
1189 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1190 (concat "Group already exists: " new-name
))
1191 (throw 'return nil
))
1192 (setq srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
))
1194 (rename-file (concat srv-dir gname
)
1195 (concat srv-dir new-name
))
1197 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1198 (concat "Error renaming link: " (prin1-to-string err
)))
1199 (throw 'return nil
)))
1200 (setq x
(nnmaildir--srv-groups nnmaildir--cur-server
)
1201 groups
(make-vector (length x
) 0))
1202 (mapatoms (lambda (sym)
1203 (unless (eq (symbol-value sym
) group
)
1204 (set (intern (symbol-name sym
) groups
)
1205 (symbol-value sym
))))
1207 (setq group
(copy-sequence group
))
1208 (setf (nnmaildir--grp-name group
) new-name
)
1209 (set (intern new-name groups
) group
)
1210 (setf (nnmaildir--srv-groups nnmaildir--cur-server
) groups
)
1213 (defun nnmaildir-request-delete-group (gname force
&optional server
)
1214 (let ((group (nnmaildir--prepare server gname
))
1215 pgname grp-dir target dir ls deactivate-mark
)
1218 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1219 (concat "No such group: " gname
))
1220 (throw 'return nil
))
1221 (setq gname
(nnmaildir--grp-name group
)
1222 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1223 grp-dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1224 target
(car (file-attributes (concat grp-dir gname
)))
1225 grp-dir
(nnmaildir--srvgrp-dir grp-dir gname
))
1226 (unless (or force
(stringp target
))
1227 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1228 (concat "Not a symlink: " gname
))
1229 (throw 'return nil
))
1230 (if (eq group
(nnmaildir--srv-curgrp nnmaildir--cur-server
))
1231 (setf (nnmaildir--srv-curgrp nnmaildir--cur-server
) nil
))
1232 (unintern gname
(nnmaildir--srv-groups nnmaildir--cur-server
))
1235 (setq grp-dir
(directory-file-name grp-dir
))
1236 (nnmaildir--unlink grp-dir
))
1237 (setq ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
))
1238 (if (nnmaildir--param pgname
'read-only
)
1239 (progn (delete-directory (nnmaildir--tmp grp-dir
))
1240 (nnmaildir--unlink (nnmaildir--new grp-dir
))
1241 (delete-directory (nnmaildir--cur grp-dir
)))
1242 (nnmaildir--delete-dir-files (nnmaildir--tmp grp-dir
) ls
)
1243 (nnmaildir--delete-dir-files (nnmaildir--new grp-dir
) ls
)
1244 (nnmaildir--delete-dir-files (nnmaildir--cur grp-dir
) ls
))
1245 (setq dir
(nnmaildir--nndir grp-dir
))
1246 (dolist (subdir `(,(nnmaildir--nov-dir dir
) ,(nnmaildir--num-dir dir
)
1247 ,@(funcall ls
(nnmaildir--marks-dir dir
)
1248 'full
"\\`[^.]" 'nosort
)))
1249 (nnmaildir--delete-dir-files subdir ls
))
1250 (setq dir
(nnmaildir--nndir grp-dir
))
1251 (nnmaildir--unlink (concat dir
"markfile"))
1252 (nnmaildir--unlink (concat dir
"markfile{new}"))
1253 (delete-directory (nnmaildir--marks-dir dir
))
1254 (delete-directory dir
)
1255 (if (not (stringp target
))
1256 (delete-directory grp-dir
)
1257 (setq grp-dir
(directory-file-name grp-dir
)
1259 (unless (eq (aref "/" 0) (aref dir
0))
1260 (setq dir
(concat (file-truename
1261 (nnmaildir--srv-dir nnmaildir--cur-server
))
1263 (delete-directory dir
)
1264 (nnmaildir--unlink grp-dir
)))
1267 (defun nnmaildir-retrieve-headers (articles &optional gname server fetch-old
)
1268 (let ((group (nnmaildir--prepare server gname
))
1269 nlist mlist article num start stop nov insert-nov
1273 (setq nov
(nnmaildir--update-nov nnmaildir--cur-server group
1276 (nnmaildir--cache-nov group article nov
)
1277 (setq num
(nnmaildir--art-num article
))
1278 (princ num nntp-server-buffer
)
1279 (insert "\t" (nnmaildir--nov-get-beg nov
) "\t"
1280 (nnmaildir--art-msgid article
) "\t"
1281 (nnmaildir--nov-get-mid nov
) "\tXref: nnmaildir "
1282 (replace-regexp-in-string " " "\\ " gname nil t
) ":")
1283 (princ num nntp-server-buffer
)
1284 (insert "\t" (nnmaildir--nov-get-end nov
) "\n"))))
1287 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1288 (if gname
(concat "No such group: " gname
) "No current group"))
1289 (throw 'return nil
))
1290 (nnmaildir--with-nntp-buffer
1292 (setq mlist
(nnmaildir--grp-mlist group
)
1293 nlist
(nnmaildir--grp-nlist group
)
1294 gname
(nnmaildir--grp-name group
))
1297 ((and fetch-old
(not (numberp fetch-old
)))
1298 (nnmaildir--nlist-iterate nlist
'all insert-nov
))
1300 ((stringp (car articles
))
1301 (dolist (msgid articles
)
1302 (setq article
(nnmaildir--mlist-art mlist msgid
))
1303 (if article
(funcall insert-nov article
))))
1306 ;; Assume the article range list is sorted ascending
1307 (setq stop
(car articles
)
1308 start
(car (last articles
))
1309 stop
(if (numberp stop
) stop
(car stop
))
1310 start
(if (numberp start
) start
(cdr start
))
1311 stop
(- stop fetch-old
)
1312 stop
(if (< stop
1) 1 stop
)
1313 articles
(list (cons stop start
))))
1314 (nnmaildir--nlist-iterate nlist articles insert-nov
)))
1315 (sort-numeric-fields 1 (point-min) (point-max))
1318 (defun nnmaildir-request-article (num-msgid &optional gname server to-buffer
)
1319 (let ((group (nnmaildir--prepare server gname
))
1320 (case-fold-search t
)
1321 list article dir pgname deactivate-mark
)
1324 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1325 (if gname
(concat "No such group: " gname
) "No current group"))
1326 (throw 'return nil
))
1327 (if (numberp num-msgid
)
1328 (setq article
(nnmaildir--nlist-art group num-msgid
))
1329 (setq list
(nnmaildir--grp-mlist group
)
1330 article
(nnmaildir--mlist-art list num-msgid
))
1331 (if article
(setq num-msgid
(nnmaildir--art-num article
))
1335 (setq group
(symbol-value group-sym
)
1336 list
(nnmaildir--grp-mlist group
)
1337 article
(nnmaildir--mlist-art list num-msgid
))
1339 (setq num-msgid
(nnmaildir--art-num article
))
1340 (throw 'found nil
)))
1341 (nnmaildir--srv-groups nnmaildir--cur-server
))))
1343 (setf (nnmaildir--srv-error nnmaildir--cur-server
) "No such article")
1344 (throw 'return nil
)))
1345 (setq gname
(nnmaildir--grp-name group
)
1346 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1347 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1348 dir
(nnmaildir--srvgrp-dir dir gname
)
1349 dir
(if (nnmaildir--param pgname
'read-only
)
1350 (nnmaildir--new dir
) (nnmaildir--cur dir
))
1351 nnmaildir-article-file-name
1353 (nnmaildir--art-prefix article
)
1354 (nnmaildir--art-suffix article
)))
1355 (unless (file-exists-p nnmaildir-article-file-name
)
1356 (nnmaildir--expired-article group article
)
1357 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1358 "Article has expired")
1359 (throw 'return nil
))
1360 (with-current-buffer (or to-buffer nntp-server-buffer
)
1362 (nnheader-insert-file-contents nnmaildir-article-file-name
))
1363 (cons gname num-msgid
))))
1365 (defun nnmaildir-request-post (&optional _server
)
1366 (let (message-required-mail-headers)
1367 (funcall message-send-mail-function
)))
1369 (defun nnmaildir-request-replace-article (number gname buffer
)
1370 (let ((group (nnmaildir--prepare nil gname
))
1371 (coding-system-for-write nnheader-file-coding-system
)
1372 (buffer-file-coding-system nil
)
1373 (file-coding-system-alist nil
)
1374 dir file article suffix tmpfile deactivate-mark
)
1377 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1378 (concat "No such group: " gname
))
1379 (throw 'return nil
))
1380 (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname
)
1382 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1383 (concat "Read-only group: " group
))
1384 (throw 'return nil
))
1385 (setq dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1386 dir
(nnmaildir--srvgrp-dir dir gname
)
1387 article
(nnmaildir--nlist-art group number
))
1389 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1390 (concat "No such article: " (number-to-string number
)))
1391 (throw 'return nil
))
1392 (setq suffix
(nnmaildir--art-suffix article
)
1393 file
(nnmaildir--art-prefix article
)
1394 tmpfile
(concat (nnmaildir--tmp dir
) file
))
1395 (when (file-exists-p tmpfile
)
1396 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1397 (concat "File exists: " tmpfile
))
1398 (throw 'return nil
))
1399 (with-current-buffer buffer
1400 (write-region (point-min) (point-max) tmpfile nil
'no-message nil
1402 (unix-sync) ;; no fsync :(
1403 (rename-file tmpfile
(concat (nnmaildir--cur dir
) file suffix
) 'replace
)
1406 (defun nnmaildir-request-move-article (article gname server accept-form
1407 &optional _last _move-is-internal
)
1408 (let ((group (nnmaildir--prepare server gname
))
1409 pgname suffix result nnmaildir--file deactivate-mark
)
1412 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1413 (concat "No such group: " gname
))
1414 (throw 'return nil
))
1415 (setq gname
(nnmaildir--grp-name group
)
1416 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1417 article
(nnmaildir--nlist-art group article
))
1419 (setf (nnmaildir--srv-error nnmaildir--cur-server
) "No such article")
1420 (throw 'return nil
))
1421 (setq suffix
(nnmaildir--art-suffix article
)
1422 nnmaildir--file
(nnmaildir--srv-dir nnmaildir--cur-server
)
1423 nnmaildir--file
(nnmaildir--srvgrp-dir nnmaildir--file gname
)
1424 nnmaildir--file
(if (nnmaildir--param pgname
'read-only
)
1425 (nnmaildir--new nnmaildir--file
)
1426 (nnmaildir--cur nnmaildir--file
))
1427 nnmaildir--file
(concat nnmaildir--file
1428 (nnmaildir--art-prefix article
)
1430 (unless (file-exists-p nnmaildir--file
)
1431 (nnmaildir--expired-article group article
)
1432 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1433 "Article has expired")
1434 (throw 'return nil
))
1435 (nnmaildir--with-move-buffer
1437 (nnheader-insert-file-contents nnmaildir--file
)
1438 (setq result
(eval accept-form
)))
1439 (unless (or (null result
) (nnmaildir--param pgname
'read-only
))
1440 (nnmaildir--unlink nnmaildir--file
)
1441 (nnmaildir--expired-article group article
))
1444 (defun nnmaildir-request-accept-article (gname &optional server _last
)
1445 (let ((group (nnmaildir--prepare server gname
))
1446 (coding-system-for-write nnheader-file-coding-system
)
1447 (buffer-file-coding-system nil
)
1448 (file-coding-system-alist nil
)
1449 srv-dir dir file time tmpfile curfile
24h article
)
1452 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1453 (concat "No such group: " gname
))
1454 (throw 'return nil
))
1455 (setq gname
(nnmaildir--grp-name group
))
1456 (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname
)
1458 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1459 (concat "Read-only group: " gname
))
1460 (throw 'return nil
))
1461 (setq srv-dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1462 dir
(nnmaildir--srvgrp-dir srv-dir gname
)
1464 file
(format-time-string "%s." time
))
1465 (unless (string-equal nnmaildir--delivery-time file
)
1466 (setq nnmaildir--delivery-time file
1467 nnmaildir--delivery-count
0))
1468 (when (and (consp (cdr time
))
1469 (consp (cddr time
)))
1470 (setq file
(concat file
"M" (number-to-string (caddr time
)))))
1471 (setq file
(concat file nnmaildir--delivery-pid
)
1472 file
(concat file
"Q" (number-to-string nnmaildir--delivery-count
))
1473 file
(concat file
"." (nnmaildir--system-name))
1474 tmpfile
(concat (nnmaildir--tmp dir
) file
)
1475 curfile
(concat (nnmaildir--cur dir
) file
":2,"))
1476 (when (file-exists-p tmpfile
)
1477 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1478 (concat "File exists: " tmpfile
))
1479 (throw 'return nil
))
1480 (when (file-exists-p curfile
)
1481 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1482 (concat "File exists: " curfile
))
1483 (throw 'return nil
))
1484 (setq nnmaildir--delivery-count
(1+ nnmaildir--delivery-count
)
1485 24h
(run-with-timer 86400 nil
1487 (nnmaildir--unlink tmpfile
)
1488 (setf (nnmaildir--srv-error
1489 nnmaildir--cur-server
)
1490 "24-hour timer expired")
1491 (throw 'return nil
))))
1492 (condition-case nil
(add-name-to-file nnmaildir--file tmpfile
)
1494 (write-region (point-min) (point-max) tmpfile nil
'no-message nil
1496 (when (fboundp 'unix-sync
)
1497 (unix-sync)))) ;; no fsync :(
1498 (nnheader-cancel-timer 24h
)
1500 (add-name-to-file tmpfile curfile
)
1502 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1503 (concat "Error linking: " (prin1-to-string err
)))
1504 (nnmaildir--unlink tmpfile
)
1505 (throw 'return nil
)))
1506 (nnmaildir--unlink tmpfile
)
1507 (setq article
(make-nnmaildir--art :prefix file
:suffix
":2,"))
1508 (if (nnmaildir--grp-add-art nnmaildir--cur-server group article
)
1509 (cons gname
(nnmaildir--art-num article
))))))
1511 (defun nnmaildir-save-mail (group-art)
1514 (throw 'return nil
))
1515 (let (ga gname x groups nnmaildir--file deactivate-mark
)
1517 (goto-char (point-min))
1519 (while (looking-at "From ")
1520 (replace-match "X-From-Line: ")
1522 (setq groups
(nnmaildir--srv-groups nnmaildir--cur-server
)
1523 ga
(car group-art
) group-art
(cdr group-art
)
1525 (or (intern-soft gname groups
)
1526 (nnmaildir-request-create-group gname
)
1527 (throw 'return nil
)) ;; not that nnmail bothers to check :(
1528 (unless (nnmaildir-request-accept-article gname
)
1529 (throw 'return nil
))
1530 (setq nnmaildir--file
(nnmaildir--srv-dir nnmaildir--cur-server
)
1531 nnmaildir--file
(nnmaildir--srvgrp-dir nnmaildir--file gname
)
1532 x
(nnmaildir--prepare nil gname
)
1533 x
(nnmaildir--grp-nlist x
)
1535 nnmaildir--file
(concat nnmaildir--file
1536 (nnmaildir--art-prefix x
)
1537 (nnmaildir--art-suffix x
)))
1541 (setq gname
(car ga
))
1542 (and (or (intern-soft gname groups
)
1543 (nnmaildir-request-create-group gname
))
1544 (nnmaildir-request-accept-article gname
)
1548 (defun nnmaildir-active-number (_gname)
1551 (declare-function gnus-group-mark-article-read
"gnus-group" (group article
))
1553 (defun nnmaildir-request-expire-articles (ranges &optional gname server force
)
1554 (let ((no-force (not force
))
1555 (group (nnmaildir--prepare server gname
))
1556 pgname time boundary bound-iter high low target dir nlist
1557 didnt nnmaildir--file nnmaildir-article-file-name
1561 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1562 (if gname
(concat "No such group: " gname
) "No current group"))
1563 (throw 'return
(gnus-uncompress-range ranges
)))
1564 (setq gname
(nnmaildir--grp-name group
)
1565 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
))
1566 (if (nnmaildir--param pgname
'read-only
)
1567 (throw 'return
(gnus-uncompress-range ranges
)))
1568 (setq time
(nnmaildir--param pgname
'expire-age
))
1570 (setq time
(or (and nnmail-expiry-wait-function
1571 (funcall nnmail-expiry-wait-function gname
))
1572 nnmail-expiry-wait
))
1573 (if (eq time
'immediate
)
1576 (setq time
(round (* time
86400))))))
1578 (unless (integerp time
) ;; handle 'never
1579 (throw 'return
(gnus-uncompress-range ranges
)))
1580 (setq boundary
(current-time)
1581 high
(- (car boundary
) (/ time
65536))
1582 low
(- (cadr boundary
) (% time
65536)))
1584 (setq low
(+ low
65536)
1586 (setcar (cdr boundary
) low
)
1587 (setcar boundary high
))
1588 (setq dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1589 dir
(nnmaildir--srvgrp-dir dir gname
)
1590 dir
(nnmaildir--cur dir
)
1591 nlist
(nnmaildir--grp-nlist group
)
1592 ranges
(reverse ranges
))
1593 (nnmaildir--with-move-buffer
1594 (nnmaildir--nlist-iterate
1597 (setq nnmaildir--file
(nnmaildir--art-prefix article
)
1598 nnmaildir--file
(concat dir nnmaildir--file
1599 (nnmaildir--art-suffix article
))
1600 time
(file-attributes nnmaildir--file
))
1603 (nnmaildir--expired-article group article
))
1606 (setq time
(nth 5 time
)
1607 bound-iter boundary
)
1608 (while (and bound-iter time
1609 (= (car bound-iter
) (car time
)))
1610 (setq bound-iter
(cdr bound-iter
)
1612 (and bound-iter time
1613 (car-less-than-car bound-iter time
))))
1614 (setq didnt
(cons (nnmaildir--art-num article
) didnt
)))
1616 (setq nnmaildir-article-file-name nnmaildir--file
1617 target
(if force nil
1620 (nnmaildir--param pgname
'expire-group
)))))
1621 (when (and (stringp target
)
1622 (not (string-equal target pgname
))) ;; Move it.
1624 (nnheader-insert-file-contents nnmaildir--file
)
1625 (let ((group-art (gnus-request-accept-article
1626 target nil nil
'no-encode
)))
1627 (when (consp group-art
)
1628 ;; Maybe also copy: dormant forward reply save tick
1629 ;; (gnus-add-mark? gnus-request-set-mark?)
1630 (gnus-group-mark-article-read target
(cdr group-art
)))))
1631 (if (equal target pgname
)
1633 (setq didnt
(cons (nnmaildir--art-num article
) didnt
))
1634 (nnmaildir--unlink nnmaildir--file
)
1635 (nnmaildir--expired-article group article
))))))
1639 (defvar nnmaildir--article
)
1641 (defun nnmaildir-request-set-mark (gname actions
&optional server
)
1642 (let* ((group (nnmaildir--prepare server gname
))
1643 (curdir (nnmaildir--cur
1644 (nnmaildir--srvgrp-dir
1645 (nnmaildir--srv-dir nnmaildir--cur-server
)
1647 (coding-system-for-write nnheader-file-coding-system
)
1648 (buffer-file-coding-system nil
)
1649 (file-coding-system-alist nil
)
1651 ranges all-marks todo-marks mdir mfile
1652 pgname ls permarkfile deactivate-mark
1655 (let ((prefix (nnmaildir--art-prefix nnmaildir--article
))
1656 (suffix (nnmaildir--art-suffix nnmaildir--article
))
1657 (flag (nnmaildir--mark-to-flag mark
)))
1659 ;; If this mark corresponds to a flag, remove the flag from
1661 (nnmaildir--article-set-flags
1662 nnmaildir--article
(nnmaildir--remove-flag flag suffix
)
1664 ;; We still want to delete the hardlink in the marks dir if
1665 ;; present, regardless of whether this mark has a maildir flag or
1666 ;; not, to avoid getting out of sync.
1667 (setq mfile
(nnmaildir--subdir marksdir
(symbol-name mark
))
1668 mfile
(concat mfile prefix
))
1669 (nnmaildir--unlink mfile
))))
1670 (del-action (lambda (article)
1671 (let ((nnmaildir--article article
))
1672 (mapcar del-mark todo-marks
))))
1677 (let ((prefix (nnmaildir--art-prefix article
))
1678 (suffix (nnmaildir--art-suffix article
))
1679 (flag (nnmaildir--mark-to-flag mark
)))
1681 ;; If there is a corresponding maildir flag, just rename
1683 (nnmaildir--article-set-flags
1684 article
(nnmaildir--add-flag flag suffix
) curdir
)
1685 ;; Otherwise, use nnmaildir-specific marks dir.
1686 (setq mdir
(nnmaildir--subdir marksdir
(symbol-name mark
))
1687 permarkfile
(concat mdir
":")
1688 mfile
(concat mdir prefix
))
1689 (nnmaildir--condcase err
(add-name-to-file permarkfile mfile
)
1691 ((nnmaildir--eexist-p err
))
1692 ((nnmaildir--enoent-p err
)
1693 (nnmaildir--mkdir mdir
)
1694 (nnmaildir--mkfile permarkfile
)
1695 (add-name-to-file permarkfile mfile
))
1696 ((nnmaildir--emlink-p err
)
1697 (let ((permarkfilenew (concat permarkfile
"{new}")))
1698 (nnmaildir--mkfile permarkfilenew
)
1699 (rename-file permarkfilenew permarkfile
'replace
)
1700 (add-name-to-file permarkfile mfile
)))
1701 (t (signal (car err
) (cdr err
))))))))
1703 (set-action (lambda (article)
1704 (funcall add-action article
)
1705 (let ((nnmaildir--article article
))
1706 (mapcar (lambda (mark)
1707 (unless (memq mark todo-marks
)
1708 (funcall del-mark mark
)))
1712 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1713 (concat "No such group: " gname
))
1714 (dolist (action actions
)
1715 (setq ranges
(gnus-range-add ranges
(car action
))))
1716 (throw 'return ranges
))
1717 (setq nlist
(nnmaildir--grp-nlist group
)
1718 marksdir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1719 marksdir
(nnmaildir--srvgrp-dir marksdir gname
)
1720 marksdir
(nnmaildir--nndir marksdir
)
1721 marksdir
(nnmaildir--marks-dir marksdir
)
1722 gname
(nnmaildir--grp-name group
)
1723 pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1724 ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
)
1725 all-marks
(funcall ls marksdir nil
"\\`[^.]" 'nosort
)
1726 all-marks
(gnus-delete-duplicates
1727 ;; get mark names from mark dirs and from flag
1730 (mapcar 'cdr nnmaildir-flag-mark-mapping
)
1731 (mapcar 'intern all-marks
))))
1732 (dolist (action actions
)
1733 (setq ranges
(car action
)
1734 todo-marks
(caddr action
))
1735 (dolist (mark todo-marks
)
1736 (pushnew mark all-marks
:test
#'equal
))
1737 (if (numberp (cdr ranges
)) (setq ranges
(list ranges
)))
1738 (nnmaildir--nlist-iterate nlist ranges
1739 (cond ((eq 'del
(cadr action
)) del-action
)
1740 ((eq 'add
(cadr action
)) add-action
)
1741 ((eq 'set
(cadr action
)) set-action
))))
1744 (defun nnmaildir-close-group (gname &optional server
)
1745 (let ((group (nnmaildir--prepare server gname
))
1746 pgname ls dir msgdir files flist dirs
)
1749 (setf (nnmaildir--srv-error nnmaildir--cur-server
)
1750 (concat "No such group: " gname
))
1752 (setq pgname
(nnmaildir--pgname nnmaildir--cur-server gname
)
1753 ls
(nnmaildir--group-ls nnmaildir--cur-server pgname
)
1754 dir
(nnmaildir--srv-dir nnmaildir--cur-server
)
1755 dir
(nnmaildir--srvgrp-dir dir gname
)
1756 msgdir
(if (nnmaildir--param pgname
'read-only
)
1757 (nnmaildir--new dir
) (nnmaildir--cur dir
))
1758 dir
(nnmaildir--nndir dir
)
1759 dirs
(cons (nnmaildir--nov-dir dir
)
1760 (funcall ls
(nnmaildir--marks-dir dir
) 'full
"\\`[^.]"
1764 (cons dir
(funcall ls dir nil
"\\`[^.]" 'nosort
)))
1766 files
(funcall ls msgdir nil
"\\`[^.]" 'nosort
)
1767 flist
(nnmaildir--up2-1 (length files
))
1768 flist
(make-vector flist
0))
1770 (dolist (file files
)
1771 (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file
)
1772 (intern (match-string 1 file
) flist
)))
1774 (setq files
(cdr dir
)
1775 dir
(file-name-as-directory (car dir
)))
1776 (dolist (file files
)
1777 (unless (or (intern-soft file flist
) (string= file
":"))
1778 (setq file
(concat dir file
))
1779 (delete-file file
))))
1782 (defun nnmaildir-close-server (&optional server
)
1783 (defvar flist
) (defvar ls
) (defvar dirs
) (defvar dir
)
1784 (defvar files
) (defvar file
) (defvar x
)
1785 (let (flist ls dirs dir files file x
)
1786 (nnmaildir--prepare server nil
)
1787 (when nnmaildir--cur-server
1788 (setq server nnmaildir--cur-server
1789 nnmaildir--cur-server nil
)
1790 (unintern (nnmaildir--srv-address server
) nnmaildir--servers
)))
1793 (defun nnmaildir-request-close ()
1794 (let (servers buffer
)
1795 (mapatoms (lambda (server)
1796 (setq servers
(cons (symbol-name server
) servers
)))
1798 (mapc 'nnmaildir-close-server servers
)
1799 (setq buffer
(get-buffer " *nnmaildir work*"))
1800 (if buffer
(kill-buffer buffer
))
1801 (setq buffer
(get-buffer " *nnmaildir nov*"))
1802 (if buffer
(kill-buffer buffer
))
1803 (setq buffer
(get-buffer " *nnmaildir move*"))
1804 (if buffer
(kill-buffer buffer
)))
1807 (provide 'nnmaildir
)
1810 ;; indent-tabs-mode: t
1814 ;;; nnmaildir.el ends here