Fix support of scripts in w32font.c (Bug#19993)
[emacs.git] / lisp / gnus / nnmaildir.el
blob21fa5b37aa465de582e7fc5411153c8b1ed25797
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/>.
22 ;;; Commentary:
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.
42 ;; Todo:
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.
50 ;;; Code:
52 ;; eval this before editing
53 [(progn
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)
62 (require 'nnheader)
63 (require 'gnus)
64 (require 'gnus-util)
65 (require 'gnus-range)
66 (require 'gnus-start)
67 (require 'gnus-int)
68 (require 'message)
69 (require 'nnmail)
71 (eval-when-compile
72 (require 'cl))
74 (defconst nnmaildir-version "Gnus")
76 (defconst nnmaildir-flag-mark-mapping
77 '((?F . tick)
78 (?R . reply)
79 (?S . read))
80 "Alist mapping Maildir filename flags to Gnus marks.
81 Maildir filenames are of the form \"unique-id:2,FLAGS\",
82 where FLAGS are a string of characters in ASCII order.
83 Some of the FLAGS correspond to Gnus marks.")
85 (defsubst nnmaildir--mark-to-flag (mark)
86 "Find the Maildir flag that corresponds to MARK (an atom).
87 Return a character, or `nil' if not found.
88 See `nnmaildir-flag-mark-mapping'."
89 (car (rassq mark nnmaildir-flag-mark-mapping)))
91 (defsubst nnmaildir--flag-to-mark (flag)
92 "Find the Gnus mark that corresponds to FLAG (a character).
93 Return an atom, or `nil' if not found.
94 See `nnmaildir-flag-mark-mapping'."
95 (cdr (assq flag nnmaildir-flag-mark-mapping)))
97 (defun nnmaildir--ensure-suffix (filename)
98 "Ensure that FILENAME contains the suffix \":2,\"."
99 (if (gnus-string-match-p ":2," filename)
100 filename
101 (concat filename ":2,")))
103 (defun nnmaildir--add-flag (flag suffix)
104 "Return a copy of SUFFIX where FLAG is set.
105 SUFFIX should start with \":2,\"."
106 (unless (gnus-string-match-p "^:2," suffix)
107 (error "Invalid suffix `%s'" suffix))
108 (let* ((flags (substring suffix 3))
109 (flags-as-list (append flags nil))
110 (new-flags
111 (concat (gnus-delete-duplicates
112 ;; maildir flags must be sorted
113 (sort (cons flag flags-as-list) '<)))))
114 (concat ":2," new-flags)))
116 (defun nnmaildir--remove-flag (flag suffix)
117 "Return a copy of SUFFIX where FLAG is cleared.
118 SUFFIX should start with \":2,\"."
119 (unless (gnus-string-match-p "^:2," suffix)
120 (error "Invalid suffix `%s'" suffix))
121 (let* ((flags (substring suffix 3))
122 (flags-as-list (append flags nil))
123 (new-flags (concat (delq flag flags-as-list))))
124 (concat ":2," new-flags)))
126 (defvar nnmaildir-article-file-name nil
127 "*The filename of the most recently requested article. This variable is set
128 by nnmaildir-request-article.")
130 ;; The filename of the article being moved/copied:
131 (defvar nnmaildir--file nil)
133 ;; Variables to generate filenames of messages being delivered:
134 (defvar nnmaildir--delivery-time "")
135 (defconst nnmaildir--delivery-pid (concat "P" (number-to-string (emacs-pid))))
136 (defvar nnmaildir--delivery-count nil)
138 ;; An obarry containing symbols whose names are server names and whose values
139 ;; are servers:
140 (defvar nnmaildir--servers (make-vector 3 0))
141 ;; The current server:
142 (defvar nnmaildir--cur-server nil)
144 ;; A copy of nnmail-extra-headers
145 (defvar nnmaildir--extra nil)
147 ;; A NOV structure looks like this (must be prin1-able, so no defstruct):
148 ["subject\tfrom\tdate"
149 "references\tchars\lines"
150 "To: you\tIn-Reply-To: <your.mess@ge>"
151 (12345 67890) ;; modtime of the corresponding article file
152 (to in-reply-to)] ;; contemporary value of nnmail-extra-headers
153 (defconst nnmaildir--novlen 5)
154 (defmacro nnmaildir--nov-new (beg mid end mtime extra)
155 `(vector ,beg ,mid ,end ,mtime ,extra))
156 (defmacro nnmaildir--nov-get-beg (nov) `(aref ,nov 0))
157 (defmacro nnmaildir--nov-get-mid (nov) `(aref ,nov 1))
158 (defmacro nnmaildir--nov-get-end (nov) `(aref ,nov 2))
159 (defmacro nnmaildir--nov-get-mtime (nov) `(aref ,nov 3))
160 (defmacro nnmaildir--nov-get-extra (nov) `(aref ,nov 4))
161 (defmacro nnmaildir--nov-set-beg (nov value) `(aset ,nov 0 ,value))
162 (defmacro nnmaildir--nov-set-mid (nov value) `(aset ,nov 1 ,value))
163 (defmacro nnmaildir--nov-set-end (nov value) `(aset ,nov 2 ,value))
164 (defmacro nnmaildir--nov-set-mtime (nov value) `(aset ,nov 3 ,value))
165 (defmacro nnmaildir--nov-set-extra (nov value) `(aset ,nov 4 ,value))
167 (defstruct nnmaildir--art
168 (prefix nil :type string) ;; "time.pid.host"
169 (suffix nil :type string) ;; ":2,flags"
170 (num nil :type natnum) ;; article number
171 (msgid nil :type string) ;; "<mess.age@id>"
172 (nov nil :type vector)) ;; cached nov structure, or nil
174 (defstruct nnmaildir--grp
175 (name nil :type string) ;; "group.name"
176 (new nil :type list) ;; new/ modtime
177 (cur nil :type list) ;; cur/ modtime
178 (min 1 :type natnum) ;; minimum article number
179 (count 0 :type natnum) ;; count of articles
180 (nlist nil :type list) ;; list of articles, ordered descending by number
181 (flist nil :type vector) ;; obarray mapping filename prefix->article
182 (mlist nil :type vector) ;; obarray mapping message-id->article
183 (cache nil :type vector) ;; nov cache
184 (index nil :type natnum) ;; index of next cache entry to replace
185 (mmth nil :type vector)) ;; obarray mapping mark name->dir modtime
186 ; ("Mark Mod Time Hash")
188 (defstruct nnmaildir--srv
189 (address nil :type string) ;; server address string
190 (method nil :type list) ;; (nnmaildir "address" ...)
191 (prefix nil :type string) ;; "nnmaildir+address:"
192 (dir nil :type string) ;; "/expanded/path/to/server/dir/"
193 (ls nil :type function) ;; directory-files function
194 (groups nil :type vector) ;; obarray mapping group name->group
195 (curgrp nil :type nnmaildir--grp) ;; current group, or nil
196 (error nil :type string) ;; last error message, or nil
197 (mtime nil :type list) ;; modtime of dir
198 (gnm nil) ;; flag: split from mail-sources?
199 (target-prefix nil :type string)) ;; symlink target prefix
201 (defun nnmaildir--article-set-flags (article new-suffix curdir)
202 (let* ((prefix (nnmaildir--art-prefix article))
203 (suffix (nnmaildir--art-suffix article))
204 (article-file (concat curdir prefix suffix))
205 (new-name (concat curdir prefix new-suffix)))
206 (unless (file-exists-p article-file)
207 (error "Couldn't find article file %s" article-file))
208 (rename-file article-file new-name 'replace)
209 (setf (nnmaildir--art-suffix article) new-suffix)))
211 (defun nnmaildir--expired-article (group article)
212 (setf (nnmaildir--art-nov article) nil)
213 (let ((flist (nnmaildir--grp-flist group))
214 (mlist (nnmaildir--grp-mlist group))
215 (min (nnmaildir--grp-min group))
216 (count (1- (nnmaildir--grp-count group)))
217 (prefix (nnmaildir--art-prefix article))
218 (msgid (nnmaildir--art-msgid article))
219 (new-nlist nil)
220 (nlist-pre '(nil . nil))
221 nlist-post num)
222 (unless (zerop count)
223 (setq nlist-post (nnmaildir--grp-nlist group)
224 num (nnmaildir--art-num article))
225 (if (eq num (caar nlist-post))
226 (setq new-nlist (cdr nlist-post))
227 (setq new-nlist nlist-post
228 nlist-pre nlist-post
229 nlist-post (cdr nlist-post))
230 (while (/= num (caar nlist-post))
231 (setq nlist-pre nlist-post
232 nlist-post (cdr nlist-post)))
233 (setq nlist-post (cdr nlist-post))
234 (if (eq num min)
235 (setq min (caar nlist-pre)))))
236 (let ((inhibit-quit t))
237 (setf (nnmaildir--grp-min group) min)
238 (setf (nnmaildir--grp-count group) count)
239 (setf (nnmaildir--grp-nlist group) new-nlist)
240 (setcdr nlist-pre nlist-post)
241 (unintern prefix flist)
242 (unintern msgid mlist))))
244 (defun nnmaildir--nlist-art (group num)
245 (let ((entry (assq num (nnmaildir--grp-nlist group))))
246 (if entry
247 (cdr entry))))
248 (defmacro nnmaildir--flist-art (list file)
249 `(symbol-value (intern-soft ,file ,list)))
250 (defmacro nnmaildir--mlist-art (list msgid)
251 `(symbol-value (intern-soft ,msgid ,list)))
253 (defun nnmaildir--pgname (server gname)
254 (let ((prefix (nnmaildir--srv-prefix server)))
255 (if prefix (concat prefix gname)
256 (setq gname (gnus-group-prefixed-name gname
257 (nnmaildir--srv-method server)))
258 (setf (nnmaildir--srv-prefix server) (gnus-group-real-prefix gname))
259 gname)))
261 (defun nnmaildir--param (pgname param)
262 (setq param (gnus-group-find-parameter pgname param 'allow-list))
263 (if (vectorp param) (setq param (aref param 0)))
264 (eval param))
266 (defmacro nnmaildir--with-nntp-buffer (&rest body)
267 (declare (debug (body)))
268 `(with-current-buffer nntp-server-buffer
269 ,@body))
270 (defmacro nnmaildir--with-work-buffer (&rest body)
271 (declare (debug (body)))
272 `(with-current-buffer (get-buffer-create " *nnmaildir work*")
273 ,@body))
274 (defmacro nnmaildir--with-nov-buffer (&rest body)
275 (declare (debug (body)))
276 `(with-current-buffer (get-buffer-create " *nnmaildir nov*")
277 ,@body))
278 (defmacro nnmaildir--with-move-buffer (&rest body)
279 (declare (debug (body)))
280 `(with-current-buffer (get-buffer-create " *nnmaildir move*")
281 ,@body))
283 (defsubst nnmaildir--subdir (dir subdir)
284 (file-name-as-directory (concat dir subdir)))
285 (defsubst nnmaildir--srvgrp-dir (srv-dir gname)
286 (nnmaildir--subdir srv-dir gname))
287 (defsubst nnmaildir--tmp (dir) (nnmaildir--subdir dir "tmp"))
288 (defsubst nnmaildir--new (dir) (nnmaildir--subdir dir "new"))
289 (defsubst nnmaildir--cur (dir) (nnmaildir--subdir dir "cur"))
290 (defsubst nnmaildir--nndir (dir) (nnmaildir--subdir dir ".nnmaildir"))
291 (defsubst nnmaildir--nov-dir (dir) (nnmaildir--subdir dir "nov"))
292 (defsubst nnmaildir--marks-dir (dir) (nnmaildir--subdir dir "marks"))
293 (defsubst nnmaildir--num-dir (dir) (nnmaildir--subdir dir "num"))
295 (defmacro nnmaildir--unlink (file-arg)
296 `(let ((file ,file-arg))
297 (if (file-attributes file) (delete-file file))))
298 (defun nnmaildir--mkdir (dir)
299 (or (file-exists-p (file-name-as-directory dir))
300 (make-directory-internal (directory-file-name dir))))
301 (defun nnmaildir--mkfile (file)
302 (write-region "" nil file nil 'no-message))
303 (defun nnmaildir--delete-dir-files (dir ls)
304 (when (file-attributes dir)
305 (mapc 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort))
306 (delete-directory dir)))
308 (defun nnmaildir--group-maxnum (server group)
309 (catch 'return
310 (if (zerop (nnmaildir--grp-count group)) (throw 'return 0))
311 (let ((dir (nnmaildir--srvgrp-dir (nnmaildir--srv-dir server)
312 (nnmaildir--grp-name group)))
313 (number-opened 1)
314 attr ino-opened nlink number-linked)
315 (setq dir (nnmaildir--nndir dir)
316 dir (nnmaildir--num-dir dir))
317 (while t
318 (setq attr (file-attributes
319 (concat dir (number-to-string number-opened))))
320 (or attr (throw 'return (1- number-opened)))
321 (setq ino-opened (nth 10 attr)
322 nlink (nth 1 attr)
323 number-linked (+ number-opened nlink))
324 (if (or (< nlink 1) (< number-linked nlink))
325 (signal 'error '("Arithmetic overflow")))
326 (setq attr (file-attributes
327 (concat dir (number-to-string number-linked))))
328 (or attr (throw 'return (1- number-linked)))
329 (unless (equal ino-opened (nth 10 attr))
330 (setq number-opened number-linked))))))
332 ;; Make the given server, if non-nil, be the current server. Then make the
333 ;; given group, if non-nil, be the current group of the current server. Then
334 ;; return the group object for the current group.
335 (defun nnmaildir--prepare (server group)
336 (let (x groups)
337 (catch 'return
338 (if (null server)
339 (unless (setq server nnmaildir--cur-server)
340 (throw 'return nil))
341 (unless (setq server (intern-soft server nnmaildir--servers))
342 (throw 'return nil))
343 (setq server (symbol-value server)
344 nnmaildir--cur-server server))
345 (unless (setq groups (nnmaildir--srv-groups server))
346 (throw 'return nil))
347 (unless (nnmaildir--srv-method server)
348 (setq x (concat "nnmaildir:" (nnmaildir--srv-address server))
349 x (gnus-server-to-method x))
350 (unless x (throw 'return nil))
351 (setf (nnmaildir--srv-method server) x))
352 (if (null group)
353 (unless (setq group (nnmaildir--srv-curgrp server))
354 (throw 'return nil))
355 (unless (setq group (intern-soft group groups))
356 (throw 'return nil))
357 (setq group (symbol-value group)))
358 group)))
360 (defun nnmaildir--tab-to-space (string)
361 (let ((pos 0))
362 (while (string-match "\t" string pos)
363 (aset string (match-beginning 0) ? )
364 (setq pos (match-end 0))))
365 string)
367 (defmacro nnmaildir--condcase (errsym body &rest handler)
368 (declare (debug (sexp form body)))
369 `(condition-case ,errsym
370 (let ((system-messages-locale "C")) ,body)
371 (error . ,handler)))
373 (defun nnmaildir--emlink-p (err)
374 (and (eq (car err) 'file-error)
375 (string= (downcase (caddr err)) "too many links")))
377 (defun nnmaildir--enoent-p (err)
378 (and (eq (car err) 'file-error)
379 (string= (downcase (caddr err)) "no such file or directory")))
381 (defun nnmaildir--eexist-p (err)
382 (eq (car err) 'file-already-exists))
384 (defun nnmaildir--new-number (nndir)
385 "Allocate a new article number by atomically creating a file under NNDIR."
386 (let ((numdir (nnmaildir--num-dir nndir))
387 (make-new-file t)
388 (number-open 1)
389 number-link previous-number-link path-open path-link ino-open)
390 (nnmaildir--mkdir numdir)
391 (catch 'return
392 (while t
393 (setq path-open (concat numdir (number-to-string number-open)))
394 (if (not make-new-file)
395 (setq previous-number-link number-link)
396 (nnmaildir--mkfile path-open)
397 ;; If Emacs had O_CREAT|O_EXCL, we could return number-open here.
398 (setq make-new-file nil
399 previous-number-link 0))
400 (let* ((attr (file-attributes path-open))
401 (nlink (nth 1 attr)))
402 (setq ino-open (nth 10 attr)
403 number-link (+ number-open nlink))
404 (if (or (< nlink 1) (< number-link nlink))
405 (signal 'error '("Arithmetic overflow"))))
406 (if (= number-link previous-number-link)
407 ;; We've already tried this number, in the previous loop iteration,
408 ;; and failed.
409 (signal 'error `("Corrupt internal nnmaildir data" ,path-open)))
410 (setq path-link (concat numdir (number-to-string number-link)))
411 (nnmaildir--condcase err
412 (progn
413 (add-name-to-file path-open path-link)
414 (throw 'return number-link))
415 (cond
416 ((nnmaildir--emlink-p err)
417 (setq make-new-file t
418 number-open number-link))
419 ((nnmaildir--eexist-p err)
420 (let ((attr (file-attributes path-link)))
421 (unless (equal (nth 10 attr) ino-open)
422 (setq number-open number-link
423 number-link 0))))
424 (t (signal (car err) (cdr err)))))))))
426 (defun nnmaildir--update-nov (server group article)
427 (let ((nnheader-file-coding-system 'binary)
428 (srv-dir (nnmaildir--srv-dir server))
429 (storage-version 1) ;; [version article-number msgid [...nov...]]
430 dir gname pgname msgdir prefix suffix file attr mtime novdir novfile
431 nov msgid nov-beg nov-mid nov-end field val old-extra num numdir
432 deactivate-mark)
433 (catch 'return
434 (setq gname (nnmaildir--grp-name group)
435 pgname (nnmaildir--pgname server gname)
436 dir (nnmaildir--srvgrp-dir srv-dir gname)
437 msgdir (if (nnmaildir--param pgname 'read-only)
438 (nnmaildir--new dir) (nnmaildir--cur dir))
439 prefix (nnmaildir--art-prefix article)
440 suffix (nnmaildir--art-suffix article)
441 file (concat msgdir prefix suffix)
442 attr (file-attributes file))
443 (unless attr
444 (nnmaildir--expired-article group article)
445 (throw 'return nil))
446 (setq mtime (nth 5 attr)
447 attr (nth 7 attr)
448 nov (nnmaildir--art-nov article)
449 dir (nnmaildir--nndir dir)
450 novdir (nnmaildir--nov-dir dir)
451 novfile (concat novdir prefix))
452 (unless (equal nnmaildir--extra nnmail-extra-headers)
453 (setq nnmaildir--extra (copy-sequence nnmail-extra-headers)))
454 (nnmaildir--with-nov-buffer
455 ;; First we'll check for already-parsed NOV data.
456 (cond ((not (file-exists-p novfile))
457 ;; The NOV file doesn't exist; we have to parse the message.
458 (setq nov nil))
459 ((not nov)
460 ;; The file exists, but the data isn't in memory; read the file.
461 (erase-buffer)
462 (nnheader-insert-file-contents novfile)
463 (setq nov (read (current-buffer)))
464 (if (not (and (vectorp nov)
465 (/= 0 (length nov))
466 (equal storage-version (aref nov 0))))
467 ;; This NOV data seems to be in the wrong format.
468 (setq nov nil)
469 (unless (nnmaildir--art-num article)
470 (setf (nnmaildir--art-num article) (aref nov 1)))
471 (unless (nnmaildir--art-msgid article)
472 (setf (nnmaildir--art-msgid article) (aref nov 2)))
473 (setq nov (aref nov 3)))))
474 ;; Now check whether the already-parsed data (if we have any) is
475 ;; usable: if the message has been edited or if nnmail-extra-headers
476 ;; has been augmented since this data was parsed from the message,
477 ;; then we have to reparse. Otherwise it's up-to-date.
478 (when (and nov (equal mtime (nnmaildir--nov-get-mtime nov)))
479 ;; The timestamp matches. Now check nnmail-extra-headers.
480 (setq old-extra (nnmaildir--nov-get-extra nov))
481 (when (equal nnmaildir--extra old-extra) ;; common case
482 ;; Save memory; use a single copy of the list value.
483 (nnmaildir--nov-set-extra nov nnmaildir--extra)
484 (throw 'return nov))
485 ;; They're not equal, but maybe the new is a subset of the old.
486 (if (null nnmaildir--extra)
487 ;; The empty set is a subset of every set.
488 (throw 'return nov))
489 (if (not (memq nil (mapcar (lambda (e) (memq e old-extra))
490 nnmaildir--extra)))
491 (throw 'return nov)))
492 ;; Parse the NOV data out of the message.
493 (erase-buffer)
494 (nnheader-insert-file-contents file)
495 (insert "\n")
496 (goto-char (point-min))
497 (save-restriction
498 (if (search-forward "\n\n" nil 'noerror)
499 (progn
500 (setq nov-mid (count-lines (point) (point-max)))
501 (narrow-to-region (point-min) (1- (point))))
502 (setq nov-mid 0))
503 (goto-char (point-min))
504 (delete-char 1)
505 (setq nov (nnheader-parse-naked-head)
506 field (or (mail-header-lines nov) 0)))
507 (unless (or (zerop field) (nnmaildir--param pgname 'distrust-Lines:))
508 (setq nov-mid field))
509 (setq nov-mid (number-to-string nov-mid)
510 nov-mid (concat (number-to-string attr) "\t" nov-mid))
511 (save-match-data
512 (setq field (or (mail-header-references nov) ""))
513 (nnmaildir--tab-to-space field)
514 (setq nov-mid (concat field "\t" nov-mid)
515 nov-beg (mapconcat
516 (lambda (f) (nnmaildir--tab-to-space (or f "")))
517 (list (mail-header-subject nov)
518 (mail-header-from nov)
519 (mail-header-date nov)) "\t")
520 nov-end (mapconcat
521 (lambda (extra)
522 (setq field (symbol-name (car extra))
523 val (cdr extra))
524 (nnmaildir--tab-to-space field)
525 (nnmaildir--tab-to-space val)
526 (concat field ": " val))
527 (mail-header-extra nov) "\t")))
528 (setq msgid (mail-header-id nov))
529 (if (or (null msgid) (nnheader-fake-message-id-p msgid))
530 (setq msgid (concat "<" prefix "@nnmaildir>")))
531 (nnmaildir--tab-to-space msgid)
532 ;; The data is parsed; create an nnmaildir NOV structure.
533 (setq nov (nnmaildir--nov-new nov-beg nov-mid nov-end mtime
534 nnmaildir--extra)
535 num (nnmaildir--art-num article))
536 (unless num
537 (setq num (nnmaildir--new-number dir))
538 (setf (nnmaildir--art-num article) num))
539 ;; Store this new NOV data in a file
540 (erase-buffer)
541 (prin1 (vector storage-version num msgid nov) (current-buffer))
542 (setq file (concat novfile ":"))
543 (nnmaildir--unlink file)
544 (gmm-write-region (point-min) (point-max) file nil 'no-message nil
545 'excl))
546 (rename-file file novfile 'replace)
547 (setf (nnmaildir--art-msgid article) msgid)
548 nov)))
550 (defun nnmaildir--cache-nov (group article nov)
551 (let ((cache (nnmaildir--grp-cache group))
552 (index (nnmaildir--grp-index group))
553 goner)
554 (unless (nnmaildir--art-nov article)
555 (setq goner (aref cache index))
556 (if goner (setf (nnmaildir--art-nov goner) nil))
557 (aset cache index article)
558 (setf (nnmaildir--grp-index group) (% (1+ index) (length cache))))
559 (setf (nnmaildir--art-nov article) nov)))
561 (defun nnmaildir--grp-add-art (server group article)
562 (let ((nov (nnmaildir--update-nov server group article))
563 count num min nlist nlist-cdr insert-nlist)
564 (when nov
565 (setq count (1+ (nnmaildir--grp-count group))
566 num (nnmaildir--art-num article)
567 min (if (= count 1) num
568 (min num (nnmaildir--grp-min group)))
569 nlist (nnmaildir--grp-nlist group))
570 (if (or (null nlist) (> num (caar nlist)))
571 (setq nlist (cons (cons num article) nlist))
572 (setq insert-nlist t
573 nlist-cdr (cdr nlist))
574 (while (and nlist-cdr (< num (caar nlist-cdr)))
575 (setq nlist nlist-cdr
576 nlist-cdr (cdr nlist))))
577 (let ((inhibit-quit t))
578 (setf (nnmaildir--grp-count group) count)
579 (setf (nnmaildir--grp-min group) min)
580 (if insert-nlist
581 (setcdr nlist (cons (cons num article) nlist-cdr))
582 (setf (nnmaildir--grp-nlist group) nlist))
583 (set (intern (nnmaildir--art-prefix article)
584 (nnmaildir--grp-flist group))
585 article)
586 (set (intern (nnmaildir--art-msgid article)
587 (nnmaildir--grp-mlist group))
588 article)
589 (set (intern (nnmaildir--grp-name group)
590 (nnmaildir--srv-groups server))
591 group))
592 (nnmaildir--cache-nov group article nov)
593 t)))
595 (defun nnmaildir--group-ls (server pgname)
596 (or (nnmaildir--param pgname 'directory-files)
597 (nnmaildir--srv-ls server)))
599 (defun nnmaildir-article-number-to-file-name
600 (number group-name server-address-string)
601 (let ((group (nnmaildir--prepare server-address-string group-name))
602 article dir pgname)
603 (catch 'return
604 (unless group
605 ;; The given group or server does not exist.
606 (throw 'return nil))
607 (setq article (nnmaildir--nlist-art group number))
608 (unless article
609 ;; The given article number does not exist in this group.
610 (throw 'return nil))
611 (setq pgname (nnmaildir--pgname nnmaildir--cur-server group-name)
612 dir (nnmaildir--srv-dir nnmaildir--cur-server)
613 dir (nnmaildir--srvgrp-dir dir group-name)
614 dir (if (nnmaildir--param pgname 'read-only)
615 (nnmaildir--new dir) (nnmaildir--cur dir)))
616 (concat dir (nnmaildir--art-prefix article)
617 (nnmaildir--art-suffix article)))))
619 (defun nnmaildir-article-number-to-base-name
620 (number group-name server-address-string)
621 (let ((x (nnmaildir--prepare server-address-string group-name)))
622 (when x
623 (setq x (nnmaildir--nlist-art x number))
624 (and x (cons (nnmaildir--art-prefix x)
625 (nnmaildir--art-suffix x))))))
627 (defun nnmaildir-base-name-to-article-number
628 (base-name group-name server-address-string)
629 (let ((x (nnmaildir--prepare server-address-string group-name)))
630 (when x
631 (setq x (nnmaildir--grp-flist x)
632 x (nnmaildir--flist-art x base-name))
633 (and x (nnmaildir--art-num x)))))
635 (defun nnmaildir--nlist-iterate (nlist ranges func)
636 (let (entry high low nlist2)
637 (if (eq ranges 'all)
638 (setq ranges `((1 . ,(caar nlist)))))
639 (while ranges
640 (setq entry (car ranges) ranges (cdr ranges))
641 (while (and ranges (eq entry (car ranges)))
642 (setq ranges (cdr ranges))) ;; skip duplicates
643 (if (numberp entry)
644 (setq low entry
645 high entry)
646 (setq low (car entry)
647 high (cdr entry)))
648 (setq nlist2 nlist) ;; Don't assume any sorting of ranges
649 (catch 'iterate-loop
650 (while nlist2
651 (if (<= (caar nlist2) high) (throw 'iterate-loop nil))
652 (setq nlist2 (cdr nlist2))))
653 (catch 'iterate-loop
654 (while nlist2
655 (setq entry (car nlist2) nlist2 (cdr nlist2))
656 (if (< (car entry) low) (throw 'iterate-loop nil))
657 (funcall func (cdr entry)))))))
659 (defun nnmaildir--up2-1 (n)
660 (if (zerop n) 1 (1- (lsh 1 (1+ (logb n))))))
662 (defun nnmaildir--system-name ()
663 (gnus-replace-in-string
664 (gnus-replace-in-string
665 (gnus-replace-in-string
666 (system-name)
667 "\\\\" "\\134" 'literal)
668 "/" "\\057" 'literal)
669 ":" "\\072" 'literal))
671 (defun nnmaildir-request-type (group &optional article)
672 'mail)
674 (defun nnmaildir-status-message (&optional server)
675 (nnmaildir--prepare server nil)
676 (nnmaildir--srv-error nnmaildir--cur-server))
678 (defun nnmaildir-server-opened (&optional server)
679 (and nnmaildir--cur-server
680 (if server
681 (string-equal server (nnmaildir--srv-address nnmaildir--cur-server))
683 (nnmaildir--srv-groups nnmaildir--cur-server)
686 (defun nnmaildir-open-server (server &optional defs)
687 (let ((x server)
688 dir size)
689 (catch 'return
690 (setq server (intern-soft x nnmaildir--servers))
691 (if server
692 (and (setq server (symbol-value server))
693 (nnmaildir--srv-groups server)
694 (setq nnmaildir--cur-server server)
695 (throw 'return t))
696 (setq server (make-nnmaildir--srv :address x))
697 (let ((inhibit-quit t))
698 (set (intern x nnmaildir--servers) server)))
699 (setq dir (assq 'directory defs))
700 (unless dir
701 (setf (nnmaildir--srv-error server)
702 "You must set \"directory\" in the select method")
703 (throw 'return nil))
704 (setq dir (cadr dir)
705 dir (eval dir)
706 dir (expand-file-name dir)
707 dir (file-name-as-directory dir))
708 (unless (file-exists-p dir)
709 (setf (nnmaildir--srv-error server) (concat "No such directory: " dir))
710 (throw 'return nil))
711 (setf (nnmaildir--srv-dir server) dir)
712 (setq x (assq 'directory-files defs))
713 (if (null x)
714 (setq x (if nnheader-directory-files-is-safe 'directory-files
715 'nnheader-directory-files-safe))
716 (setq x (cadr x))
717 (unless (functionp x)
718 (setf (nnmaildir--srv-error server)
719 (concat "Not a function: " (prin1-to-string x)))
720 (throw 'return nil)))
721 (setf (nnmaildir--srv-ls server) x)
722 (setq size (length (funcall x dir nil "\\`[^.]" 'nosort))
723 size (nnmaildir--up2-1 size))
724 (and (setq x (assq 'get-new-mail defs))
725 (setq x (cdr x))
726 (car x)
727 (setf (nnmaildir--srv-gnm server) t)
728 (require 'nnmail))
729 (setq x (assq 'target-prefix defs))
730 (if x
731 (progn
732 (setq x (cadr x)
733 x (eval x))
734 (setf (nnmaildir--srv-target-prefix server) x))
735 (setq x (assq 'create-directory defs))
736 (if x
737 (progn
738 (setq x (cadr x)
739 x (eval x)
740 x (file-name-as-directory x))
741 (setf (nnmaildir--srv-target-prefix server) x))
742 (setf (nnmaildir--srv-target-prefix server) "")))
743 (setf (nnmaildir--srv-groups server) (make-vector size 0))
744 (setq nnmaildir--cur-server server)
745 t)))
747 (defun nnmaildir--parse-filename (file)
748 (let ((prefix (car file))
749 timestamp len)
750 (if (string-match "\\`\\([0-9]+\\)\\(\\..*\\)\\'" prefix)
751 (progn
752 (setq timestamp (concat "0000" (match-string 1 prefix))
753 len (- (length timestamp) 4))
754 (vector (string-to-number (substring timestamp 0 len))
755 (string-to-number (substring timestamp len))
756 (match-string 2 prefix)
757 file))
758 file)))
760 (defun nnmaildir--sort-files (a b)
761 (catch 'return
762 (if (consp a)
763 (throw 'return (and (consp b) (string-lessp (car a) (car b)))))
764 (if (consp b) (throw 'return t))
765 (if (< (aref a 0) (aref b 0)) (throw 'return t))
766 (if (> (aref a 0) (aref b 0)) (throw 'return nil))
767 (if (< (aref a 1) (aref b 1)) (throw 'return t))
768 (if (> (aref a 1) (aref b 1)) (throw 'return nil))
769 (string-lessp (aref a 2) (aref b 2))))
771 (defun nnmaildir--scan (gname scan-msgs groups method srv-dir srv-ls)
772 (catch 'return
773 (let ((36h-ago (- (car (current-time)) 2))
774 absdir nndir tdir ndir cdir nattr cattr isnew pgname read-only ls
775 files num dir flist group x)
776 (setq absdir (nnmaildir--srvgrp-dir srv-dir gname)
777 nndir (nnmaildir--nndir absdir))
778 (unless (file-exists-p absdir)
779 (setf (nnmaildir--srv-error nnmaildir--cur-server)
780 (concat "No such directory: " absdir))
781 (throw 'return nil))
782 (setq tdir (nnmaildir--tmp absdir)
783 ndir (nnmaildir--new absdir)
784 cdir (nnmaildir--cur absdir)
785 nattr (file-attributes ndir)
786 cattr (file-attributes cdir))
787 (unless (and (file-exists-p tdir) nattr cattr)
788 (setf (nnmaildir--srv-error nnmaildir--cur-server)
789 (concat "Not a maildir: " absdir))
790 (throw 'return nil))
791 (setq group (nnmaildir--prepare nil gname)
792 pgname (nnmaildir--pgname nnmaildir--cur-server gname))
793 (if group
794 (setq isnew nil)
795 (setq isnew t
796 group (make-nnmaildir--grp :name gname :index 0))
797 (nnmaildir--mkdir nndir)
798 (nnmaildir--mkdir (nnmaildir--nov-dir nndir))
799 (nnmaildir--mkdir (nnmaildir--marks-dir nndir)))
800 (setq read-only (nnmaildir--param pgname 'read-only)
801 ls (or (nnmaildir--param pgname 'directory-files) srv-ls))
802 (unless read-only
803 (setq x (nth 11 (file-attributes tdir)))
804 (unless (and (equal x (nth 11 nattr)) (equal x (nth 11 cattr)))
805 (setf (nnmaildir--srv-error nnmaildir--cur-server)
806 (concat "Maildir spans filesystems: " absdir))
807 (throw 'return nil))
808 (dolist (file (funcall ls tdir 'full "\\`[^.]" 'nosort))
809 (setq x (file-attributes file))
810 (if (or (> (cadr x) 1) (< (car (nth 4 x)) 36h-ago))
811 (delete-file file))))
812 (or scan-msgs
813 isnew
814 (throw 'return t))
815 (setq nattr (nth 5 nattr))
816 (if (equal nattr (nnmaildir--grp-new group))
817 (setq nattr nil))
818 (if read-only (setq dir (and (or isnew nattr) ndir))
819 (when (or isnew nattr)
820 (dolist (file (funcall ls ndir nil "\\`[^.]" 'nosort))
821 (setq x (concat ndir file))
822 (and (time-less-p (nth 5 (file-attributes x)) (current-time))
823 (rename-file x (concat cdir (nnmaildir--ensure-suffix file)))))
824 (setf (nnmaildir--grp-new group) nattr))
825 (setq cattr (nth 5 (file-attributes cdir)))
826 (if (equal cattr (nnmaildir--grp-cur group))
827 (setq cattr nil))
828 (setq dir (and (or isnew cattr) cdir)))
829 (unless dir (throw 'return t))
830 (setq files (funcall ls dir nil "\\`[^.]" 'nosort)
831 files (save-match-data
832 (mapcar
833 (lambda (f)
834 (string-match "\\`\\([^:]*\\)\\(\\(:.*\\)?\\)\\'" f)
835 (cons (match-string 1 f) (match-string 2 f)))
836 files)))
837 (when isnew
838 (setq num (nnmaildir--up2-1 (length files)))
839 (setf (nnmaildir--grp-flist group) (make-vector num 0))
840 (setf (nnmaildir--grp-mlist group) (make-vector num 0))
841 (setf (nnmaildir--grp-mmth group) (make-vector 1 0))
842 (setq num (nnmaildir--param pgname 'nov-cache-size))
843 (if (numberp num) (if (< num 1) (setq num 1))
844 (setq num 16
845 cdir (nnmaildir--marks-dir nndir)
846 ndir (nnmaildir--subdir cdir "tick")
847 cdir (nnmaildir--subdir cdir "read"))
848 (dolist (prefix-suffix files)
849 (let ((prefix (car prefix-suffix))
850 (suffix (cdr prefix-suffix)))
851 ;; increase num for each unread or ticked article
852 (when (or
853 ;; first look for marks in suffix, if it's valid...
854 (when (and (stringp suffix)
855 (gnus-string-prefix-p ":2," suffix))
857 (not (gnus-string-match-p
858 (string (nnmaildir--mark-to-flag 'read)) suffix))
859 (gnus-string-match-p
860 (string (nnmaildir--mark-to-flag 'tick)) suffix)))
861 ;; then look in marks directories
862 (not (file-exists-p (concat cdir prefix)))
863 (file-exists-p (concat ndir prefix)))
864 (incf num)))))
865 (setf (nnmaildir--grp-cache group) (make-vector num nil))
866 (let ((inhibit-quit t))
867 (set (intern gname groups) group))
868 (or scan-msgs (throw 'return t)))
869 (setq flist (nnmaildir--grp-flist group)
870 files (mapcar
871 (lambda (file)
872 (and (null (nnmaildir--flist-art flist (car file)))
873 file))
874 files)
875 files (delq nil files)
876 files (mapcar 'nnmaildir--parse-filename files)
877 files (sort files 'nnmaildir--sort-files))
878 (dolist (file files)
879 (setq file (if (consp file) file (aref file 3))
880 x (make-nnmaildir--art :prefix (car file) :suffix (cdr file)))
881 (nnmaildir--grp-add-art nnmaildir--cur-server group x))
882 (if read-only (setf (nnmaildir--grp-new group) nattr)
883 (setf (nnmaildir--grp-cur group) cattr)))
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 group dirs grp-dir seen
894 deactivate-mark)
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
902 (save-match-data
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))
911 (if scan-group
912 (mapatoms (lambda (sym)
913 (nnmaildir--scan (symbol-name sym) t groups
914 method srv-dir srv-ls))
915 groups))
916 (setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort)
917 dirs (if (zerop (length target-prefix))
918 dirs
919 (gnus-remove-if
920 (lambda (dir)
921 (and (>= (length dir) (length target-prefix))
922 (string= (substring dir 0
923 (length target-prefix))
924 target-prefix)))
925 dirs))
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
930 srv-ls)
931 (intern grp-dir seen)))
932 (setq x nil)
933 (mapatoms (lambda (group)
934 (setq group (symbol-name group))
935 (unless (intern-soft group seen)
936 (setq x (cons group x))))
937 groups)
938 (dolist (grp x)
939 (unintern grp groups))
940 (setf (nnmaildir--srv-mtime nnmaildir--cur-server)
941 (nth 5 (file-attributes srv-dir))))
942 (and scan-group
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
952 (erase-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 (gnus-replace-in-string
959 (nnmaildir--grp-name group) " " "\\ " t)
960 " ")
961 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
962 nntp-server-buffer)
963 (insert " ")
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
976 (erase-buffer)
977 (dolist (gname groups)
978 (setq group (nnmaildir--prepare nil gname))
979 (if (null group) (insert "411 no such news group\n")
980 (insert "211 ")
981 (princ (nnmaildir--grp-count group) nntp-server-buffer)
982 (insert " ")
983 (princ (nnmaildir--grp-min group) nntp-server-buffer)
984 (insert " ")
985 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
986 nntp-server-buffer)
987 (insert " "
988 (gnus-replace-in-string gname " " "\\ " t)
989 "\n")))))
990 'group)
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 dotfile num dir
999 all-marks marks mark ranges markdir read end new-marks ls
1000 old-mmth new-mmth mtime mark-sym existing missing deactivate-mark)
1001 (catch 'return
1002 (unless group
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
1031 ;; mappings
1032 (append
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))
1040 ranges nil)
1041 (catch 'got-ranges
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.
1049 (setq mtime
1050 (let ((markdir-mtime (nth 5 (file-attributes markdir))))
1051 (cond
1052 ((null (nnmaildir--mark-to-flag mark))
1053 markdir-mtime)
1054 ((null markdir-mtime)
1055 curdir-mtime)
1056 ((null curdir-mtime)
1057 ;; this should never happen...
1058 markdir-mtime)
1059 ((time-less-p markdir-mtime curdir-mtime)
1060 curdir-mtime)
1062 markdir-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...
1076 (when flag
1077 (let ((regexp
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)))
1083 (when article
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)))
1089 (when article
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)
1097 info)))
1099 (defun nnmaildir-request-group (gname &optional server fast info)
1100 (let ((group (nnmaildir--prepare server gname))
1101 deactivate-mark)
1102 (catch 'return
1103 (unless group
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
1111 (erase-buffer)
1112 (insert "211 ")
1113 (princ (nnmaildir--grp-count group) nntp-server-buffer)
1114 (insert " ")
1115 (princ (nnmaildir--grp-min group) nntp-server-buffer)
1116 (insert " ")
1117 (princ (nnmaildir--group-maxnum nnmaildir--cur-server group)
1118 nntp-server-buffer)
1119 (insert " " (gnus-replace-in-string gname " " "\\ " t) "\n")
1120 t))))
1122 (defun nnmaildir-request-create-group (gname &optional server args)
1123 (nnmaildir--prepare server nil)
1124 (catch 'return
1125 (let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server))
1126 srv-dir dir groups)
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: "
1138 gname))
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))
1148 (setq dir srv-dir
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)
1166 srv-dir x groups)
1167 (catch 'return
1168 (unless group
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: "
1183 new-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))
1192 (condition-case err
1193 (rename-file (concat srv-dir gname)
1194 (concat srv-dir new-name))
1195 (error
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)
1210 t)))
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)
1215 (catch 'return
1216 (unless group
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))
1232 (if (not force)
1233 (progn
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)
1257 dir target)
1258 (unless (eq (aref "/" 0) (aref dir 0))
1259 (setq dir (concat (file-truename
1260 (nnmaildir--srv-dir nnmaildir--cur-server))
1261 dir)))
1262 (delete-directory dir)
1263 (nnmaildir--unlink grp-dir)))
1264 t)))
1266 (defun nnmaildir-retrieve-headers (articles &optional gname server fetch-old)
1267 (let ((group (nnmaildir--prepare server gname))
1268 srv-dir dir nlist mlist article num start stop nov nlist2 insert-nov
1269 deactivate-mark)
1270 (setq insert-nov
1271 (lambda (article)
1272 (setq nov (nnmaildir--update-nov nnmaildir--cur-server group
1273 article))
1274 (when nov
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 (gnus-replace-in-string gname " " "\\ " t) ":")
1282 (princ num nntp-server-buffer)
1283 (insert "\t" (nnmaildir--nov-get-end nov) "\n"))))
1284 (catch 'return
1285 (unless group
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
1290 (erase-buffer)
1291 (setq mlist (nnmaildir--grp-mlist group)
1292 nlist (nnmaildir--grp-nlist group)
1293 gname (nnmaildir--grp-name group)
1294 srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1295 dir (nnmaildir--srvgrp-dir srv-dir gname))
1296 (cond
1297 ((null nlist))
1298 ((and fetch-old (not (numberp fetch-old)))
1299 (nnmaildir--nlist-iterate nlist 'all insert-nov))
1300 ((null articles))
1301 ((stringp (car articles))
1302 (dolist (msgid articles)
1303 (setq article (nnmaildir--mlist-art mlist msgid))
1304 (if article (funcall insert-nov article))))
1306 (if fetch-old
1307 ;; Assume the article range list is sorted ascending
1308 (setq stop (car articles)
1309 start (car (last articles))
1310 stop (if (numberp stop) stop (car stop))
1311 start (if (numberp start) start (cdr start))
1312 stop (- stop fetch-old)
1313 stop (if (< stop 1) 1 stop)
1314 articles (list (cons stop start))))
1315 (nnmaildir--nlist-iterate nlist articles insert-nov)))
1316 (sort-numeric-fields 1 (point-min) (point-max))
1317 'nov))))
1319 (defun nnmaildir-request-article (num-msgid &optional gname server to-buffer)
1320 (let ((group (nnmaildir--prepare server gname))
1321 (case-fold-search t)
1322 list article dir pgname deactivate-mark)
1323 (catch 'return
1324 (unless group
1325 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1326 (if gname (concat "No such group: " gname) "No current group"))
1327 (throw 'return nil))
1328 (if (numberp num-msgid)
1329 (setq article (nnmaildir--nlist-art group num-msgid))
1330 (setq list (nnmaildir--grp-mlist group)
1331 article (nnmaildir--mlist-art list num-msgid))
1332 (if article (setq num-msgid (nnmaildir--art-num article))
1333 (catch 'found
1334 (mapatoms
1335 (lambda (group-sym)
1336 (setq group (symbol-value group-sym)
1337 list (nnmaildir--grp-mlist group)
1338 article (nnmaildir--mlist-art list num-msgid))
1339 (when article
1340 (setq num-msgid (nnmaildir--art-num article))
1341 (throw 'found nil)))
1342 (nnmaildir--srv-groups nnmaildir--cur-server))))
1343 (unless article
1344 (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
1345 (throw 'return nil)))
1346 (setq gname (nnmaildir--grp-name group)
1347 pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1348 dir (nnmaildir--srv-dir nnmaildir--cur-server)
1349 dir (nnmaildir--srvgrp-dir dir gname)
1350 dir (if (nnmaildir--param pgname 'read-only)
1351 (nnmaildir--new dir) (nnmaildir--cur dir))
1352 nnmaildir-article-file-name
1353 (concat dir
1354 (nnmaildir--art-prefix article)
1355 (nnmaildir--art-suffix article)))
1356 (unless (file-exists-p nnmaildir-article-file-name)
1357 (nnmaildir--expired-article group article)
1358 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1359 "Article has expired")
1360 (throw 'return nil))
1361 (with-current-buffer (or to-buffer nntp-server-buffer)
1362 (erase-buffer)
1363 (nnheader-insert-file-contents nnmaildir-article-file-name))
1364 (cons gname num-msgid))))
1366 (defun nnmaildir-request-post (&optional server)
1367 (let (message-required-mail-headers)
1368 (funcall message-send-mail-function)))
1370 (defun nnmaildir-request-replace-article (number gname buffer)
1371 (let ((group (nnmaildir--prepare nil gname))
1372 (coding-system-for-write nnheader-file-coding-system)
1373 (buffer-file-coding-system nil)
1374 (file-coding-system-alist nil)
1375 dir file article suffix tmpfile deactivate-mark)
1376 (catch 'return
1377 (unless group
1378 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1379 (concat "No such group: " gname))
1380 (throw 'return nil))
1381 (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
1382 'read-only)
1383 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1384 (concat "Read-only group: " group))
1385 (throw 'return nil))
1386 (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
1387 dir (nnmaildir--srvgrp-dir dir gname)
1388 article (nnmaildir--nlist-art group number))
1389 (unless article
1390 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1391 (concat "No such article: " (number-to-string number)))
1392 (throw 'return nil))
1393 (setq suffix (nnmaildir--art-suffix article)
1394 file (nnmaildir--art-prefix article)
1395 tmpfile (concat (nnmaildir--tmp dir) file))
1396 (when (file-exists-p tmpfile)
1397 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1398 (concat "File exists: " tmpfile))
1399 (throw 'return nil))
1400 (with-current-buffer buffer
1401 (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil
1402 'excl))
1403 (unix-sync) ;; no fsync :(
1404 (rename-file tmpfile (concat (nnmaildir--cur dir) file suffix) 'replace)
1405 t)))
1407 (defun nnmaildir-request-move-article (article gname server accept-form
1408 &optional last move-is-internal)
1409 (let ((group (nnmaildir--prepare server gname))
1410 pgname suffix result nnmaildir--file deactivate-mark)
1411 (catch 'return
1412 (unless group
1413 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1414 (concat "No such group: " gname))
1415 (throw 'return nil))
1416 (setq gname (nnmaildir--grp-name group)
1417 pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1418 article (nnmaildir--nlist-art group article))
1419 (unless article
1420 (setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article")
1421 (throw 'return nil))
1422 (setq suffix (nnmaildir--art-suffix article)
1423 nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
1424 nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname)
1425 nnmaildir--file (if (nnmaildir--param pgname 'read-only)
1426 (nnmaildir--new nnmaildir--file)
1427 (nnmaildir--cur nnmaildir--file))
1428 nnmaildir--file (concat nnmaildir--file
1429 (nnmaildir--art-prefix article)
1430 suffix))
1431 (unless (file-exists-p nnmaildir--file)
1432 (nnmaildir--expired-article group article)
1433 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1434 "Article has expired")
1435 (throw 'return nil))
1436 (nnmaildir--with-move-buffer
1437 (erase-buffer)
1438 (nnheader-insert-file-contents nnmaildir--file)
1439 (setq result (eval accept-form)))
1440 (unless (or (null result) (nnmaildir--param pgname 'read-only))
1441 (nnmaildir--unlink nnmaildir--file)
1442 (nnmaildir--expired-article group article))
1443 result)))
1445 (defun nnmaildir-request-accept-article (gname &optional server last)
1446 (let ((group (nnmaildir--prepare server gname))
1447 (coding-system-for-write nnheader-file-coding-system)
1448 (buffer-file-coding-system nil)
1449 (file-coding-system-alist nil)
1450 srv-dir dir file time tmpfile curfile 24h article)
1451 (catch 'return
1452 (unless group
1453 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1454 (concat "No such group: " gname))
1455 (throw 'return nil))
1456 (setq gname (nnmaildir--grp-name group))
1457 (when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname)
1458 'read-only)
1459 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1460 (concat "Read-only group: " gname))
1461 (throw 'return nil))
1462 (setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)
1463 dir (nnmaildir--srvgrp-dir srv-dir gname)
1464 time (current-time)
1465 file (format-time-string "%s." time))
1466 (unless (string-equal nnmaildir--delivery-time file)
1467 (setq nnmaildir--delivery-time file
1468 nnmaildir--delivery-count 0))
1469 (when (and (consp (cdr time))
1470 (consp (cddr time)))
1471 (setq file (concat file "M" (number-to-string (caddr time)))))
1472 (setq file (concat file nnmaildir--delivery-pid)
1473 file (concat file "Q" (number-to-string nnmaildir--delivery-count))
1474 file (concat file "." (nnmaildir--system-name))
1475 tmpfile (concat (nnmaildir--tmp dir) file)
1476 curfile (concat (nnmaildir--cur dir) file ":2,"))
1477 (when (file-exists-p tmpfile)
1478 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1479 (concat "File exists: " tmpfile))
1480 (throw 'return nil))
1481 (when (file-exists-p curfile)
1482 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1483 (concat "File exists: " curfile))
1484 (throw 'return nil))
1485 (setq nnmaildir--delivery-count (1+ nnmaildir--delivery-count)
1486 24h (run-with-timer 86400 nil
1487 (lambda ()
1488 (nnmaildir--unlink tmpfile)
1489 (setf (nnmaildir--srv-error
1490 nnmaildir--cur-server)
1491 "24-hour timer expired")
1492 (throw 'return nil))))
1493 (condition-case nil (add-name-to-file nnmaildir--file tmpfile)
1494 (error
1495 (gmm-write-region (point-min) (point-max) tmpfile nil 'no-message nil
1496 'excl)
1497 (when (fboundp 'unix-sync)
1498 (unix-sync)))) ;; no fsync :(
1499 (nnheader-cancel-timer 24h)
1500 (condition-case err
1501 (add-name-to-file tmpfile curfile)
1502 (error
1503 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1504 (concat "Error linking: " (prin1-to-string err)))
1505 (nnmaildir--unlink tmpfile)
1506 (throw 'return nil)))
1507 (nnmaildir--unlink tmpfile)
1508 (setq article (make-nnmaildir--art :prefix file :suffix ":2,"))
1509 (if (nnmaildir--grp-add-art nnmaildir--cur-server group article)
1510 (cons gname (nnmaildir--art-num article))))))
1512 (defun nnmaildir-save-mail (group-art)
1513 (catch 'return
1514 (unless group-art
1515 (throw 'return nil))
1516 (let (ga gname x groups nnmaildir--file deactivate-mark)
1517 (save-excursion
1518 (goto-char (point-min))
1519 (save-match-data
1520 (while (looking-at "From ")
1521 (replace-match "X-From-Line: ")
1522 (forward-line 1))))
1523 (setq groups (nnmaildir--srv-groups nnmaildir--cur-server)
1524 ga (car group-art) group-art (cdr group-art)
1525 gname (car ga))
1526 (or (intern-soft gname groups)
1527 (nnmaildir-request-create-group gname)
1528 (throw 'return nil)) ;; not that nnmail bothers to check :(
1529 (unless (nnmaildir-request-accept-article gname)
1530 (throw 'return nil))
1531 (setq nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server)
1532 nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname)
1533 x (nnmaildir--prepare nil gname)
1534 x (nnmaildir--grp-nlist x)
1535 x (cdar x)
1536 nnmaildir--file (concat nnmaildir--file
1537 (nnmaildir--art-prefix x)
1538 (nnmaildir--art-suffix x)))
1539 (delq nil
1540 (mapcar
1541 (lambda (ga)
1542 (setq gname (car ga))
1543 (and (or (intern-soft gname groups)
1544 (nnmaildir-request-create-group gname))
1545 (nnmaildir-request-accept-article gname)
1546 ga))
1547 group-art)))))
1549 (defun nnmaildir-active-number (gname)
1552 (declare-function gnus-group-mark-article-read "gnus-group" (group article))
1554 (defun nnmaildir-request-expire-articles (ranges &optional gname server force)
1555 (let ((no-force (not force))
1556 (group (nnmaildir--prepare server gname))
1557 pgname time boundary bound-iter high low target dir nlist nlist2
1558 stop article didnt nnmaildir--file nnmaildir-article-file-name
1559 deactivate-mark)
1560 (catch 'return
1561 (unless group
1562 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1563 (if gname (concat "No such group: " gname) "No current group"))
1564 (throw 'return (gnus-uncompress-range ranges)))
1565 (setq gname (nnmaildir--grp-name group)
1566 pgname (nnmaildir--pgname nnmaildir--cur-server gname))
1567 (if (nnmaildir--param pgname 'read-only)
1568 (throw 'return (gnus-uncompress-range ranges)))
1569 (setq time (nnmaildir--param pgname 'expire-age))
1570 (unless time
1571 (setq time (or (and nnmail-expiry-wait-function
1572 (funcall nnmail-expiry-wait-function gname))
1573 nnmail-expiry-wait))
1574 (if (eq time 'immediate)
1575 (setq time 0)
1576 (if (numberp time)
1577 (setq time (round (* time 86400))))))
1578 (when no-force
1579 (unless (integerp time) ;; handle 'never
1580 (throw 'return (gnus-uncompress-range ranges)))
1581 (setq boundary (current-time)
1582 high (- (car boundary) (/ time 65536))
1583 low (- (cadr boundary) (% time 65536)))
1584 (if (< low 0)
1585 (setq low (+ low 65536)
1586 high (1- high)))
1587 (setcar (cdr boundary) low)
1588 (setcar boundary high))
1589 (setq dir (nnmaildir--srv-dir nnmaildir--cur-server)
1590 dir (nnmaildir--srvgrp-dir dir gname)
1591 dir (nnmaildir--cur dir)
1592 nlist (nnmaildir--grp-nlist group)
1593 ranges (reverse ranges))
1594 (nnmaildir--with-move-buffer
1595 (nnmaildir--nlist-iterate
1596 nlist ranges
1597 (lambda (article)
1598 (setq nnmaildir--file (nnmaildir--art-prefix article)
1599 nnmaildir--file (concat dir nnmaildir--file
1600 (nnmaildir--art-suffix article))
1601 time (file-attributes nnmaildir--file))
1602 (cond
1603 ((null time)
1604 (nnmaildir--expired-article group article))
1605 ((and no-force
1606 (progn
1607 (setq time (nth 5 time)
1608 bound-iter boundary)
1609 (while (and bound-iter time
1610 (= (car bound-iter) (car time)))
1611 (setq bound-iter (cdr bound-iter)
1612 time (cdr time)))
1613 (and bound-iter time
1614 (car-less-than-car bound-iter time))))
1615 (setq didnt (cons (nnmaildir--art-num article) didnt)))
1617 (setq nnmaildir-article-file-name nnmaildir--file
1618 target (if force nil
1619 (save-excursion
1620 (save-restriction
1621 (nnmaildir--param pgname 'expire-group)))))
1622 (when (and (stringp target)
1623 (not (string-equal target pgname))) ;; Move it.
1624 (erase-buffer)
1625 (nnheader-insert-file-contents nnmaildir--file)
1626 (let ((group-art (gnus-request-accept-article
1627 target nil nil 'no-encode)))
1628 (when (consp group-art)
1629 ;; Maybe also copy: dormant forward reply save tick
1630 ;; (gnus-add-mark? gnus-request-set-mark?)
1631 (gnus-group-mark-article-read target (cdr group-art)))))
1632 (if (equal target pgname)
1633 ;; Leave it here.
1634 (setq didnt (cons (nnmaildir--art-num article) didnt))
1635 (nnmaildir--unlink nnmaildir--file)
1636 (nnmaildir--expired-article group article))))))
1637 (erase-buffer))
1638 didnt)))
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)
1645 gname)))
1646 (coding-system-for-write nnheader-file-coding-system)
1647 (buffer-file-coding-system nil)
1648 (file-coding-system-alist nil)
1649 del-mark del-action add-action set-action marksdir nlist
1650 ranges begin end article all-marks todo-marks mdir mfile
1651 pgname ls permarkfile deactivate-mark)
1652 (setq del-mark
1653 (lambda (mark)
1654 (let ((prefix (nnmaildir--art-prefix article))
1655 (suffix (nnmaildir--art-suffix article))
1656 (flag (nnmaildir--mark-to-flag mark)))
1657 (when flag
1658 ;; If this mark corresponds to a flag, remove the flag from
1659 ;; the file name.
1660 (nnmaildir--article-set-flags
1661 article (nnmaildir--remove-flag flag suffix) curdir))
1662 ;; We still want to delete the hardlink in the marks dir if
1663 ;; present, regardless of whether this mark has a maildir flag or
1664 ;; not, to avoid getting out of sync.
1665 (setq mfile (nnmaildir--subdir marksdir (symbol-name mark))
1666 mfile (concat mfile prefix))
1667 (nnmaildir--unlink mfile)))
1668 del-action (lambda (article) (mapcar del-mark todo-marks))
1669 add-action
1670 (lambda (article)
1671 (mapcar
1672 (lambda (mark)
1673 (let ((prefix (nnmaildir--art-prefix article))
1674 (suffix (nnmaildir--art-suffix article))
1675 (flag (nnmaildir--mark-to-flag mark)))
1676 (if flag
1677 ;; If there is a corresponding maildir flag, just rename
1678 ;; the file.
1679 (nnmaildir--article-set-flags
1680 article (nnmaildir--add-flag flag suffix) curdir)
1681 ;; Otherwise, use nnmaildir-specific marks dir.
1682 (setq mdir (nnmaildir--subdir marksdir (symbol-name mark))
1683 permarkfile (concat mdir ":")
1684 mfile (concat mdir prefix))
1685 (nnmaildir--condcase err (add-name-to-file permarkfile mfile)
1686 (cond
1687 ((nnmaildir--eexist-p err))
1688 ((nnmaildir--enoent-p err)
1689 (nnmaildir--mkdir mdir)
1690 (nnmaildir--mkfile permarkfile)
1691 (add-name-to-file permarkfile mfile))
1692 ((nnmaildir--emlink-p err)
1693 (let ((permarkfilenew (concat permarkfile "{new}")))
1694 (nnmaildir--mkfile permarkfilenew)
1695 (rename-file permarkfilenew permarkfile 'replace)
1696 (add-name-to-file permarkfile mfile)))
1697 (t (signal (car err) (cdr err))))))))
1698 todo-marks))
1699 set-action (lambda (article)
1700 (funcall add-action article)
1701 (mapcar (lambda (mark)
1702 (unless (memq mark todo-marks)
1703 (funcall del-mark mark)))
1704 all-marks)))
1705 (catch 'return
1706 (unless group
1707 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1708 (concat "No such group: " gname))
1709 (dolist (action actions)
1710 (setq ranges (gnus-range-add ranges (car action))))
1711 (throw 'return ranges))
1712 (setq nlist (nnmaildir--grp-nlist group)
1713 marksdir (nnmaildir--srv-dir nnmaildir--cur-server)
1714 marksdir (nnmaildir--srvgrp-dir marksdir gname)
1715 marksdir (nnmaildir--nndir marksdir)
1716 marksdir (nnmaildir--marks-dir marksdir)
1717 gname (nnmaildir--grp-name group)
1718 pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1719 ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1720 all-marks (funcall ls marksdir nil "\\`[^.]" 'nosort)
1721 all-marks (gnus-delete-duplicates
1722 ;; get mark names from mark dirs and from flag
1723 ;; mappings
1724 (append
1725 (mapcar 'cdr nnmaildir-flag-mark-mapping)
1726 (mapcar 'intern all-marks))))
1727 (dolist (action actions)
1728 (setq ranges (car action)
1729 todo-marks (caddr action))
1730 (dolist (mark todo-marks)
1731 (add-to-list 'all-marks mark))
1732 (if (numberp (cdr ranges)) (setq ranges (list ranges)))
1733 (nnmaildir--nlist-iterate nlist ranges
1734 (cond ((eq 'del (cadr action)) del-action)
1735 ((eq 'add (cadr action)) add-action)
1736 ((eq 'set (cadr action)) set-action))))
1737 nil)))
1739 (defun nnmaildir-close-group (gname &optional server)
1740 (let ((group (nnmaildir--prepare server gname))
1741 pgname ls dir msgdir files flist dirs)
1742 (if (null group)
1743 (progn
1744 (setf (nnmaildir--srv-error nnmaildir--cur-server)
1745 (concat "No such group: " gname))
1746 nil)
1747 (setq pgname (nnmaildir--pgname nnmaildir--cur-server gname)
1748 ls (nnmaildir--group-ls nnmaildir--cur-server pgname)
1749 dir (nnmaildir--srv-dir nnmaildir--cur-server)
1750 dir (nnmaildir--srvgrp-dir dir gname)
1751 msgdir (if (nnmaildir--param pgname 'read-only)
1752 (nnmaildir--new dir) (nnmaildir--cur dir))
1753 dir (nnmaildir--nndir dir)
1754 dirs (cons (nnmaildir--nov-dir dir)
1755 (funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]"
1756 'nosort))
1757 dirs (mapcar
1758 (lambda (dir)
1759 (cons dir (funcall ls dir nil "\\`[^.]" 'nosort)))
1760 dirs)
1761 files (funcall ls msgdir nil "\\`[^.]" 'nosort)
1762 flist (nnmaildir--up2-1 (length files))
1763 flist (make-vector flist 0))
1764 (save-match-data
1765 (dolist (file files)
1766 (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file)
1767 (intern (match-string 1 file) flist)))
1768 (dolist (dir dirs)
1769 (setq files (cdr dir)
1770 dir (file-name-as-directory (car dir)))
1771 (dolist (file files)
1772 (unless (or (intern-soft file flist) (string= file ":"))
1773 (setq file (concat dir file))
1774 (delete-file file))))
1775 t)))
1777 (defun nnmaildir-close-server (&optional server)
1778 (let (flist ls dirs dir files file x)
1779 (nnmaildir--prepare server nil)
1780 (when nnmaildir--cur-server
1781 (setq server nnmaildir--cur-server
1782 nnmaildir--cur-server nil)
1783 (unintern (nnmaildir--srv-address server) nnmaildir--servers)))
1786 (defun nnmaildir-request-close ()
1787 (let (servers buffer)
1788 (mapatoms (lambda (server)
1789 (setq servers (cons (symbol-name server) servers)))
1790 nnmaildir--servers)
1791 (mapc 'nnmaildir-close-server servers)
1792 (setq buffer (get-buffer " *nnmaildir work*"))
1793 (if buffer (kill-buffer buffer))
1794 (setq buffer (get-buffer " *nnmaildir nov*"))
1795 (if buffer (kill-buffer buffer))
1796 (setq buffer (get-buffer " *nnmaildir move*"))
1797 (if buffer (kill-buffer buffer)))
1800 (provide 'nnmaildir)
1802 ;; Local Variables:
1803 ;; indent-tabs-mode: t
1804 ;; fill-column: 77
1805 ;; End:
1807 ;;; nnmaildir.el ends here