1 |
|
;;; nnmaildir.el --- maildir backend for Gnus |
2 |
|
;; Public domain. |
3 |
|
|
4 |
|
;; Author: Paul Jarc <prj@po.cwru.edu> |
5 |
|
|
6 |
|
;; This file is part of GNU Emacs. |
7 |
|
|
8 |
|
;; GNU Emacs is free software; you can redistribute it and/or modify |
9 |
|
;; it under the terms of the GNU General Public License as published by |
10 |
|
;; the Free Software Foundation; either version 2, or (at your option) |
11 |
|
;; any later version. |
12 |
|
|
13 |
|
;; GNU Emacs is distributed in the hope that it will be useful, |
14 |
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
15 |
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
16 |
|
;; GNU General Public License for more details. |
17 |
|
|
18 |
|
;; You should have received a copy of the GNU General Public License |
19 |
|
;; along with GNU Emacs; see the file COPYING. If not, write to the |
20 |
|
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
21 |
|
;; Boston, MA 02111-1307, USA. |
22 |
|
|
23 |
|
;;; Commentary: |
24 |
|
|
25 |
|
;; Maildir format is documented at <URL:http://cr.yp.to/proto/maildir.html> |
26 |
|
;; and in the maildir(5) man page from qmail (available at |
27 |
|
;; <URL:http://www.qmail.org/man/man5/maildir.html>). nnmaildir also stores |
28 |
|
;; extra information in the .nnmaildir/ directory within a maildir. |
29 |
|
;; |
30 |
|
;; Some goals of nnmaildir: |
31 |
|
;; * Everything Just Works, and correctly. E.g., NOV data is automatically |
32 |
|
;; regenerated when stale; no need for manually running |
33 |
|
;; *-generate-nov-databases. |
34 |
|
;; * Perfect reliability: [C-g] will never corrupt its data in memory, and |
35 |
|
;; SIGKILL will never corrupt its data in the filesystem. |
36 |
|
;; * Allow concurrent operation as much as possible. If files change out |
37 |
|
;; from under us, adapt to the changes or degrade gracefully. |
38 |
|
;; * We use the filesystem as a database, so that, e.g., it's easy to |
39 |
|
;; manipulate marks from outside Gnus. |
40 |
|
;; * All information about a group is stored in the maildir, for easy backup, |
41 |
|
;; copying, restoring, etc. |
42 |
|
;; |
43 |
|
;; Todo: |
44 |
|
;; * Add a hook for when moving messages from new/ to cur/, to support |
45 |
|
;; nnmail's duplicate detection. |
46 |
|
;; * Improve generated Xrefs, so crossposts are detectable. |
47 |
|
;; * Improve code readability. |
48 |
|
|
49 |
|
;;; Code: |
50 |
|
|
51 |
|
;; eval this before editing |
52 |
|
[(progn |
53 |
|
(put 'nnmaildir--with-nntp-buffer 'lisp-indent-function 0) |
54 |
|
(put 'nnmaildir--with-work-buffer 'lisp-indent-function 0) |
55 |
|
(put 'nnmaildir--with-nov-buffer 'lisp-indent-function 0) |
56 |
|
(put 'nnmaildir--with-move-buffer 'lisp-indent-function 0) |
57 |
|
) |
58 |
|
] |
59 |
|
|
60 |
|
(eval-and-compile |
61 |
|
(require 'nnheader) |
62 |
|
(require 'gnus) |
63 |
|
(require 'gnus-util) |
64 |
|
(require 'gnus-range) |
65 |
|
(require 'gnus-start) |
66 |
|
(require 'gnus-int) |
67 |
|
(require 'message)) |
68 |
|
(eval-when-compile |
69 |
|
(require 'cl) |
70 |
|
(require 'nnmail)) |
71 |
|
|
72 |
|
(defconst nnmaildir-version "Gnus") |
73 |
|
|
74 |
|
(defvar nnmaildir-article-file-name nil |
75 |
|
"*The filename of the most recently requested article. This variable is set |
76 |
|
by nnmaildir-request-article.") |
77 |
|
|
78 |
|
;; The filename of the article being moved/copied: |
79 |
|
(defvar nnmaildir--file nil) |
80 |
|
|
81 |
|
;; Variables to generate filenames of messages being delivered: |
82 |
|
(defvar nnmaildir--delivery-time "") |
83 |
|
(defconst nnmaildir--delivery-pid (concat "P" (number-to-string (emacs-pid)))) |
84 |
|
(defvar nnmaildir--delivery-count nil) |
85 |
|
|
86 |
|
;; An obarry containing symbols whose names are server names and whose values |
87 |
|
;; are servers: |
88 |
|
(defvar nnmaildir--servers (make-vector 3 0)) |
89 |
|
;; The current server: |
90 |
|
(defvar nnmaildir--cur-server nil) |
91 |
|
|
92 |
|
;; A copy of nnmail-extra-headers |
93 |
|
(defvar nnmaildir--extra nil) |
94 |
|
|
95 |
|
;; A NOV structure looks like this (must be prin1-able, so no defstruct): |
96 |
|
["subject\tfrom\tdate" |
97 |
|
"references\tchars\lines" |
98 |
|
"To: you\tIn-Reply-To: <your.mess@ge>" |
99 |
|
(12345 67890) ;; modtime of the corresponding article file |
100 |
|
(to in-reply-to)] ;; contemporary value of nnmail-extra-headers |
101 |
|
(defconst nnmaildir--novlen 5) |
102 |
|
(defmacro nnmaildir--nov-new (beg mid end mtime extra) |
103 |
|
`(vector ,beg ,mid ,end ,mtime ,extra)) |
104 |
|
(defmacro nnmaildir--nov-get-beg (nov) `(aref ,nov 0)) |
105 |
|
(defmacro nnmaildir--nov-get-mid (nov) `(aref ,nov 1)) |
106 |
|
(defmacro nnmaildir--nov-get-end (nov) `(aref ,nov 2)) |
107 |
|
(defmacro nnmaildir--nov-get-mtime (nov) `(aref ,nov 3)) |
108 |
|
(defmacro nnmaildir--nov-get-extra (nov) `(aref ,nov 4)) |
109 |
|
(defmacro nnmaildir--nov-set-beg (nov value) `(aset ,nov 0 ,value)) |
110 |
|
(defmacro nnmaildir--nov-set-mid (nov value) `(aset ,nov 1 ,value)) |
111 |
|
(defmacro nnmaildir--nov-set-end (nov value) `(aset ,nov 2 ,value)) |
112 |
|
(defmacro nnmaildir--nov-set-mtime (nov value) `(aset ,nov 3 ,value)) |
113 |
|
(defmacro nnmaildir--nov-set-extra (nov value) `(aset ,nov 4 ,value)) |
114 |
|
|
115 |
|
(defstruct nnmaildir--art |
116 |
|
(prefix nil :type string) ;; "time.pid.host" |
117 |
|
(suffix nil :type string) ;; ":2,flags" |
118 |
|
(num nil :type natnum) ;; article number |
119 |
|
(msgid nil :type string) ;; "<mess.age@id>" |
120 |
|
(nov nil :type vector)) ;; cached nov structure, or nil |
121 |
|
|
122 |
|
(defstruct nnmaildir--grp |
123 |
|
(name nil :type string) ;; "group.name" |
124 |
|
(new nil :type list) ;; new/ modtime |
125 |
|
(cur nil :type list) ;; cur/ modtime |
126 |
|
(min 1 :type natnum) ;; minimum article number |
127 |
|
(count 0 :type natnum) ;; count of articles |
128 |
|
(nlist nil :type list) ;; list of articles, ordered descending by number |
129 |
|
(flist nil :type vector) ;; obarray mapping filename prefix->article |
130 |
|
(mlist nil :type vector) ;; obarray mapping message-id->article |
131 |
|
(cache nil :type vector) ;; nov cache |
132 |
|
(index nil :type natnum) ;; index of next cache entry to replace |
133 |
|
(mmth nil :type vector)) ;; obarray mapping mark name->dir modtime |
134 |
|
; ("Mark Mod Time Hash") |
135 |
|
|
136 |
|
(defstruct nnmaildir--srv |
137 |
|
(address nil :type string) ;; server address string |
138 |
|
(method nil :type list) ;; (nnmaildir "address" ...) |
139 |
|
(prefix nil :type string) ;; "nnmaildir+address:" |
140 |
|
(dir nil :type string) ;; "/expanded/path/to/server/dir/" |
141 |
|
(ls nil :type function) ;; directory-files function |
142 |
|
(groups nil :type vector) ;; obarray mapping group name->group |
143 |
|
(curgrp nil :type nnmaildir--grp) ;; current group, or nil |
144 |
|
(error nil :type string) ;; last error message, or nil |
145 |
|
(mtime nil :type list) ;; modtime of dir |
146 |
|
(gnm nil) ;; flag: split from mail-sources? |
147 |
|
(target-prefix nil :type string)) ;; symlink target prefix |
148 |
|
|
149 |
|
(defun nnmaildir--expired-article (group article) |
150 |
|
(setf (nnmaildir--art-nov article) nil) |
151 |
|
(let ((flist (nnmaildir--grp-flist group)) |
152 |
|
(mlist (nnmaildir--grp-mlist group)) |
153 |
|
(min (nnmaildir--grp-min group)) |
154 |
|
(count (1- (nnmaildir--grp-count group))) |
155 |
|
(prefix (nnmaildir--art-prefix article)) |
156 |
|
(msgid (nnmaildir--art-msgid article)) |
157 |
|
(new-nlist nil) |
158 |
|
(nlist-pre '(nil . nil)) |
159 |
|
nlist-post num) |
160 |
|
(unless (zerop count) |
161 |
|
(setq nlist-post (nnmaildir--grp-nlist group) |
162 |
|
num (nnmaildir--art-num article)) |
163 |
|
(if (eq num (caar nlist-post)) |
164 |
|
(setq new-nlist (cdr nlist-post)) |
165 |
|
(setq new-nlist nlist-post |
166 |
|
nlist-pre nlist-post |
167 |
|
nlist-post (cdr nlist-post)) |
168 |
|
(while (/= num (caar nlist-post)) |
169 |
|
(setq nlist-pre nlist-post |
170 |
|
nlist-post (cdr nlist-post))) |
171 |
|
(setq nlist-post (cdr nlist-post)) |
172 |
|
(if (eq num min) |
173 |
|
(setq min (caar nlist-pre))))) |
174 |
|
(let ((inhibit-quit t)) |
175 |
|
(setf (nnmaildir--grp-min group) min) |
176 |
|
(setf (nnmaildir--grp-count group) count) |
177 |
|
(setf (nnmaildir--grp-nlist group) new-nlist) |
178 |
|
(setcdr nlist-pre nlist-post) |
179 |
|
(unintern prefix flist) |
180 |
|
(unintern msgid mlist)))) |
181 |
|
|
182 |
|
(defun nnmaildir--nlist-art (group num) |
183 |
|
(let ((entry (assq num (nnmaildir--grp-nlist group)))) |
184 |
|
(if entry |
185 |
|
(cdr entry)))) |
186 |
|
(defmacro nnmaildir--flist-art (list file) |
187 |
|
`(symbol-value (intern-soft ,file ,list))) |
188 |
|
(defmacro nnmaildir--mlist-art (list msgid) |
189 |
|
`(symbol-value (intern-soft ,msgid ,list))) |
190 |
|
|
191 |
|
(defun nnmaildir--pgname (server gname) |
192 |
|
(let ((prefix (nnmaildir--srv-prefix server))) |
193 |
|
(if prefix (concat prefix gname) |
194 |
|
(setq gname (gnus-group-prefixed-name gname |
195 |
|
(nnmaildir--srv-method server))) |
196 |
|
(setf (nnmaildir--srv-prefix server) (gnus-group-real-prefix gname)) |
197 |
|
gname))) |
198 |
|
|
199 |
|
(defun nnmaildir--param (pgname param) |
200 |
|
(setq param (gnus-group-find-parameter pgname param 'allow-list)) |
201 |
|
(if (vectorp param) (setq param (aref param 0))) |
202 |
|
(eval param)) |
203 |
|
|
204 |
|
(defmacro nnmaildir--with-nntp-buffer (&rest body) |
205 |
|
`(save-excursion |
206 |
|
(set-buffer nntp-server-buffer) |
207 |
|
,@body)) |
208 |
|
(defmacro nnmaildir--with-work-buffer (&rest body) |
209 |
|
`(save-excursion |
210 |
|
(set-buffer (get-buffer-create " *nnmaildir work*")) |
211 |
|
,@body)) |
212 |
|
(defmacro nnmaildir--with-nov-buffer (&rest body) |
213 |
|
`(save-excursion |
214 |
|
(set-buffer (get-buffer-create " *nnmaildir nov*")) |
215 |
|
,@body)) |
216 |
|
(defmacro nnmaildir--with-move-buffer (&rest body) |
217 |
|
`(save-excursion |
218 |
|
(set-buffer (get-buffer-create " *nnmaildir move*")) |
219 |
|
,@body)) |
220 |
|
|
221 |
|
(defmacro nnmaildir--subdir (dir subdir) |
222 |
|
`(file-name-as-directory (concat ,dir ,subdir))) |
223 |
|
(defmacro nnmaildir--srvgrp-dir (srv-dir gname) |
224 |
|
`(nnmaildir--subdir ,srv-dir ,gname)) |
225 |
|
(defmacro nnmaildir--tmp (dir) `(nnmaildir--subdir ,dir "tmp")) |
226 |
|
(defmacro nnmaildir--new (dir) `(nnmaildir--subdir ,dir "new")) |
227 |
|
(defmacro nnmaildir--cur (dir) `(nnmaildir--subdir ,dir "cur")) |
228 |
|
(defmacro nnmaildir--nndir (dir) `(nnmaildir--subdir ,dir ".nnmaildir")) |
229 |
|
(defmacro nnmaildir--nov-dir (dir) `(nnmaildir--subdir ,dir "nov")) |
230 |
|
(defmacro nnmaildir--marks-dir (dir) `(nnmaildir--subdir ,dir "marks")) |
231 |
|
(defmacro nnmaildir--num-dir (dir) `(nnmaildir--subdir ,dir "num")) |
232 |
|
(defmacro nnmaildir--num-file (dir) `(concat ,dir ":")) |
233 |
|
|
234 |
|
(defmacro nnmaildir--unlink (file-arg) |
235 |
|
`(let ((file ,file-arg)) |
236 |
|
(if (file-attributes file) (delete-file file)))) |
237 |
|
(defun nnmaildir--mkdir (dir) |
238 |
|
(or (file-exists-p (file-name-as-directory dir)) |
239 |
|
(make-directory-internal (directory-file-name dir)))) |
240 |
|
(defun nnmaildir--delete-dir-files (dir ls) |
241 |
|
(when (file-attributes dir) |
242 |
|
(mapcar 'delete-file (funcall ls dir 'full "\\`[^.]" 'nosort)) |
243 |
|
(delete-directory dir))) |
244 |
|
|
245 |
|
(defun nnmaildir--group-maxnum (server group) |
246 |
|
(if (zerop (nnmaildir--grp-count group)) 0 |
247 |
|
(let ((x (nnmaildir--srvgrp-dir (nnmaildir--srv-dir server) |
248 |
|
(nnmaildir--grp-name group)))) |
249 |
|
(setq x (nnmaildir--nndir x) |
250 |
|
x (nnmaildir--num-dir x) |
251 |
|
x (nnmaildir--num-file x) |
252 |
|
x (file-attributes x)) |
253 |
|
(if x (1- (nth 1 x)) 0)))) |
254 |
|
|
255 |
|
;; Make the given server, if non-nil, be the current server. Then make the |
256 |
|
;; given group, if non-nil, be the current group of the current server. Then |
257 |
|
;; return the group object for the current group. |
258 |
|
(defun nnmaildir--prepare (server group) |
259 |
|
(let (x groups) |
260 |
|
(catch 'return |
261 |
|
(if (null server) |
262 |
|
(unless (setq server nnmaildir--cur-server) |
263 |
|
(throw 'return nil)) |
264 |
|
(unless (setq server (intern-soft server nnmaildir--servers)) |
265 |
|
(throw 'return nil)) |
266 |
|
(setq server (symbol-value server) |
267 |
|
nnmaildir--cur-server server)) |
268 |
|
(unless (setq groups (nnmaildir--srv-groups server)) |
269 |
|
(throw 'return nil)) |
270 |
|
(unless (nnmaildir--srv-method server) |
271 |
|
(setq x (concat "nnmaildir:" (nnmaildir--srv-address server)) |
272 |
|
x (gnus-server-to-method x)) |
273 |
|
(unless x (throw 'return nil)) |
274 |
|
(setf (nnmaildir--srv-method server) x)) |
275 |
|
(if (null group) |
276 |
|
(unless (setq group (nnmaildir--srv-curgrp server)) |
277 |
|
(throw 'return nil)) |
278 |
|
(unless (setq group (intern-soft group groups)) |
279 |
|
(throw 'return nil)) |
280 |
|
(setq group (symbol-value group))) |
281 |
|
group))) |
282 |
|
|
283 |
|
(defun nnmaildir--tab-to-space (string) |
284 |
|
(let ((pos 0)) |
285 |
|
(while (string-match "\t" string pos) |
286 |
|
(aset string (match-beginning 0) ? ) |
287 |
|
(setq pos (match-end 0)))) |
288 |
|
string) |
289 |
|
|
290 |
|
(defun nnmaildir--update-nov (server group article) |
291 |
|
(let ((nnheader-file-coding-system 'binary) |
292 |
|
(srv-dir (nnmaildir--srv-dir server)) |
293 |
|
(storage-version 1) ;; [version article-number msgid [...nov...]] |
294 |
|
dir gname pgname msgdir prefix suffix file attr mtime novdir novfile |
295 |
|
nov msgid nov-beg nov-mid nov-end field val old-extra num numdir |
296 |
|
deactivate-mark) |
297 |
|
(catch 'return |
298 |
|
(setq gname (nnmaildir--grp-name group) |
299 |
|
pgname (nnmaildir--pgname server gname) |
300 |
|
dir (nnmaildir--srvgrp-dir srv-dir gname) |
301 |
|
msgdir (if (nnmaildir--param pgname 'read-only) |
302 |
|
(nnmaildir--new dir) (nnmaildir--cur dir)) |
303 |
|
prefix (nnmaildir--art-prefix article) |
304 |
|
suffix (nnmaildir--art-suffix article) |
305 |
|
file (concat msgdir prefix suffix) |
306 |
|
attr (file-attributes file)) |
307 |
|
(unless attr |
308 |
|
(nnmaildir--expired-article group article) |
309 |
|
(throw 'return nil)) |
310 |
|
(setq mtime (nth 5 attr) |
311 |
|
attr (nth 7 attr) |
312 |
|
nov (nnmaildir--art-nov article) |
313 |
|
dir (nnmaildir--nndir dir) |
314 |
|
novdir (nnmaildir--nov-dir dir) |
315 |
|
novfile (concat novdir prefix)) |
316 |
|
(unless (equal nnmaildir--extra nnmail-extra-headers) |
317 |
|
(setq nnmaildir--extra (copy-sequence nnmail-extra-headers))) |
318 |
|
(nnmaildir--with-nov-buffer |
319 |
|
;; First we'll check for already-parsed NOV data. |
320 |
|
(cond ((not (file-exists-p novfile)) |
321 |
|
;; The NOV file doesn't exist; we have to parse the message. |
322 |
|
(setq nov nil)) |
323 |
|
((not nov) |
324 |
|
;; The file exists, but the data isn't in memory; read the file. |
325 |
|
(erase-buffer) |
326 |
|
(nnheader-insert-file-contents novfile) |
327 |
|
(setq nov (read (current-buffer))) |
328 |
|
(if (not (and (vectorp nov) |
329 |
|
(/= 0 (length nov)) |
330 |
|
(equal storage-version (aref nov 0)))) |
331 |
|
;; This NOV data seems to be in the wrong format. |
332 |
|
(setq nov nil) |
333 |
|
(unless (nnmaildir--art-num article) |
334 |
|
(setf (nnmaildir--art-num article) (aref nov 1))) |
335 |
|
(unless (nnmaildir--art-msgid article) |
336 |
|
(setf (nnmaildir--art-msgid article) (aref nov 2))) |
337 |
|
(setq nov (aref nov 3))))) |
338 |
|
;; Now check whether the already-parsed data (if we have any) is |
339 |
|
;; usable: if the message has been edited or if nnmail-extra-headers |
340 |
|
;; has been augmented since this data was parsed from the message, |
341 |
|
;; then we have to reparse. Otherwise it's up-to-date. |
342 |
|
(when (and nov (equal mtime (nnmaildir--nov-get-mtime nov))) |
343 |
|
;; The timestamp matches. Now check nnmail-extra-headers. |
344 |
|
(setq old-extra (nnmaildir--nov-get-extra nov)) |
345 |
|
(when (equal nnmaildir--extra old-extra) ;; common case |
346 |
|
;; Save memory; use a single copy of the list value. |
347 |
|
(nnmaildir--nov-set-extra nov nnmaildir--extra) |
348 |
|
(throw 'return nov)) |
349 |
|
;; They're not equal, but maybe the new is a subset of the old. |
350 |
|
(if (null nnmaildir--extra) |
351 |
|
;; The empty set is a subset of every set. |
352 |
|
(throw 'return nov)) |
353 |
|
(if (not (memq nil (mapcar (lambda (e) (memq e old-extra)) |
354 |
|
nnmaildir--extra))) |
355 |
|
(throw 'return nov))) |
356 |
|
;; Parse the NOV data out of the message. |
357 |
|
(erase-buffer) |
358 |
|
(nnheader-insert-file-contents file) |
359 |
|
(insert "\n") |
360 |
|
(goto-char (point-min)) |
361 |
|
(save-restriction |
362 |
|
(if (search-forward "\n\n" nil 'noerror) |
363 |
|
(progn |
364 |
|
(setq nov-mid (count-lines (point) (point-max))) |
365 |
|
(narrow-to-region (point-min) (1- (point)))) |
366 |
|
(setq nov-mid 0)) |
367 |
|
(goto-char (point-min)) |
368 |
|
(delete-char 1) |
369 |
|
(setq nov (nnheader-parse-naked-head) |
370 |
|
field (or (mail-header-lines nov) 0))) |
371 |
|
(unless (or (zerop field) (nnmaildir--param pgname 'distrust-Lines:)) |
372 |
|
(setq nov-mid field)) |
373 |
|
(setq nov-mid (number-to-string nov-mid) |
374 |
|
nov-mid (concat (number-to-string attr) "\t" nov-mid)) |
375 |
|
(save-match-data |
376 |
|
(setq field (or (mail-header-references nov) "")) |
377 |
|
(nnmaildir--tab-to-space field) |
378 |
|
(setq nov-mid (concat field "\t" nov-mid) |
379 |
|
nov-beg (mapconcat |
380 |
|
(lambda (f) (nnmaildir--tab-to-space (or f ""))) |
381 |
|
(list (mail-header-subject nov) |
382 |
|
(mail-header-from nov) |
383 |
|
(mail-header-date nov)) "\t") |
384 |
|
nov-end (mapconcat |
385 |
|
(lambda (extra) |
386 |
|
(setq field (symbol-name (car extra)) |
387 |
|
val (cdr extra)) |
388 |
|
(nnmaildir--tab-to-space field) |
389 |
|
(nnmaildir--tab-to-space val) |
390 |
|
(concat field ": " val)) |
391 |
|
(mail-header-extra nov) "\t"))) |
392 |
|
(setq msgid (mail-header-id nov)) |
393 |
|
(if (or (null msgid) (nnheader-fake-message-id-p msgid)) |
394 |
|
(setq msgid (concat "<" prefix "@nnmaildir>"))) |
395 |
|
(nnmaildir--tab-to-space msgid) |
396 |
|
;; The data is parsed; create an nnmaildir NOV structure. |
397 |
|
(setq nov (nnmaildir--nov-new nov-beg nov-mid nov-end mtime |
398 |
|
nnmaildir--extra) |
399 |
|
num (nnmaildir--art-num article)) |
400 |
|
(unless num |
401 |
|
;; Allocate a new article number. |
402 |
|
(erase-buffer) |
403 |
|
(setq numdir (nnmaildir--num-dir dir) |
404 |
|
file (nnmaildir--num-file numdir) |
405 |
|
num -1) |
406 |
|
(nnmaildir--mkdir numdir) |
407 |
|
(write-region "" nil file nil 'no-message) |
408 |
|
(while file |
409 |
|
;; Get the number of links to file. |
410 |
|
(setq attr (nth 1 (file-attributes file))) |
411 |
|
(if (= attr num) |
412 |
|
;; We've already tried this number, in the previous loop |
413 |
|
;; iteration, and failed. |
414 |
|
(signal 'error `("Corrupt internal nnmaildir data" ,numdir))) |
415 |
|
;; If attr is 123, try to link file to "123". This atomically |
416 |
|
;; increases the link count and creates the "123" link, failing |
417 |
|
;; if that link was already created by another Gnus, just after |
418 |
|
;; we stat()ed file. |
419 |
|
(condition-case nil |
420 |
|
(progn |
421 |
|
(add-name-to-file file (concat numdir (format "%x" attr))) |
422 |
|
(setq file nil)) ;; Stop looping. |
423 |
|
(file-already-exists nil)) |
424 |
|
(setq num attr)) |
425 |
|
(setf (nnmaildir--art-num article) num)) |
426 |
|
;; Store this new NOV data in a file |
427 |
|
(erase-buffer) |
428 |
|
(prin1 (vector storage-version num msgid nov) (current-buffer)) |
429 |
|
(setq file (concat novfile ":")) |
430 |
|
(nnmaildir--unlink file) |
431 |
|
(write-region (point-min) (point-max) file nil 'no-message nil 'excl)) |
432 |
|
(rename-file file novfile 'replace) |
433 |
|
(setf (nnmaildir--art-msgid article) msgid) |
434 |
|
nov))) |
435 |
|
|
436 |
|
(defun nnmaildir--cache-nov (group article nov) |
437 |
|
(let ((cache (nnmaildir--grp-cache group)) |
438 |
|
(index (nnmaildir--grp-index group)) |
439 |
|
goner) |
440 |
|
(unless (nnmaildir--art-nov article) |
441 |
|
(setq goner (aref cache index)) |
442 |
|
(if goner (setf (nnmaildir--art-nov goner) nil)) |
443 |
|
(aset cache index article) |
444 |
|
(setf (nnmaildir--grp-index group) (% (1+ index) (length cache)))) |
445 |
|
(setf (nnmaildir--art-nov article) nov))) |
446 |
|
|
447 |
|
(defun nnmaildir--grp-add-art (server group article) |
448 |
|
(let ((nov (nnmaildir--update-nov server group article)) |
449 |
|
count num min nlist nlist-cdr insert-nlist) |
450 |
|
(when nov |
451 |
|
(setq count (1+ (nnmaildir--grp-count group)) |
452 |
|
num (nnmaildir--art-num article) |
453 |
|
min (if (= count 1) num |
454 |
|
(min num (nnmaildir--grp-min group))) |
455 |
|
nlist (nnmaildir--grp-nlist group)) |
456 |
|
(if (or (null nlist) (> num (caar nlist))) |
457 |
|
(setq nlist (cons (cons num article) nlist)) |
458 |
|
(setq insert-nlist t |
459 |
|
nlist-cdr (cdr nlist)) |
460 |
|
(while (and nlist-cdr (< num (caar nlist-cdr))) |
461 |
|
(setq nlist nlist-cdr |
462 |
|
nlist-cdr (cdr nlist)))) |
463 |
|
(let ((inhibit-quit t)) |
464 |
|
(setf (nnmaildir--grp-count group) count) |
465 |
|
(setf (nnmaildir--grp-min group) min) |
466 |
|
(if insert-nlist |
467 |
|
(setcdr nlist (cons (cons num article) nlist-cdr)) |
468 |
|
(setf (nnmaildir--grp-nlist group) nlist)) |
469 |
|
(set (intern (nnmaildir--art-prefix article) |
470 |
|
(nnmaildir--grp-flist group)) |
471 |
|
article) |
472 |
|
(set (intern (nnmaildir--art-msgid article) |
473 |
|
(nnmaildir--grp-mlist group)) |
474 |
|
article) |
475 |
|
(set (intern (nnmaildir--grp-name group) |
476 |
|
(nnmaildir--srv-groups server)) |
477 |
|
group)) |
478 |
|
(nnmaildir--cache-nov group article nov) |
479 |
|
t))) |
480 |
|
|
481 |
|
(defun nnmaildir--group-ls (server pgname) |
482 |
|
(or (nnmaildir--param pgname 'directory-files) |
483 |
|
(nnmaildir--srv-ls server))) |
484 |
|
|
485 |
|
(defun nnmaildir-article-number-to-file-name |
486 |
|
(number group-name server-address-string) |
487 |
|
(let ((group (nnmaildir--prepare server-address-string group-name)) |
488 |
|
article dir pgname) |
489 |
|
(catch 'return |
490 |
|
(unless group |
491 |
|
;; The given group or server does not exist. |
492 |
|
(throw 'return nil)) |
493 |
|
(setq article (nnmaildir--nlist-art group number)) |
494 |
|
(unless article |
495 |
|
;; The given article number does not exist in this group. |
496 |
|
(throw 'return nil)) |
497 |
|
(setq pgname (nnmaildir--pgname nnmaildir--cur-server group-name) |
498 |
|
dir (nnmaildir--srv-dir nnmaildir--cur-server) |
499 |
|
dir (nnmaildir--srvgrp-dir dir group-name) |
500 |
|
dir (if (nnmaildir--param pgname 'read-only) |
501 |
|
(nnmaildir--new dir) (nnmaildir--cur dir))) |
502 |
|
(concat dir (nnmaildir--art-prefix article) |
503 |
|
(nnmaildir--art-suffix article))))) |
504 |
|
|
505 |
|
(defun nnmaildir-article-number-to-base-name |
506 |
|
(number group-name server-address-string) |
507 |
|
(let ((x (nnmaildir--prepare server-address-string group-name))) |
508 |
|
(when x |
509 |
|
(setq x (nnmaildir--nlist-art x number)) |
510 |
|
(and x (cons (nnmaildir--art-prefix x) |
511 |
|
(nnmaildir--art-suffix x)))))) |
512 |
|
|
513 |
|
(defun nnmaildir-base-name-to-article-number |
514 |
|
(base-name group-name server-address-string) |
515 |
|
(let ((x (nnmaildir--prepare server-address-string group-name))) |
516 |
|
(when x |
517 |
|
(setq x (nnmaildir--grp-flist x) |
518 |
|
x (nnmaildir--flist-art x base-name)) |
519 |
|
(and x (nnmaildir--art-num x))))) |
520 |
|
|
521 |
|
(defun nnmaildir--nlist-iterate (nlist ranges func) |
522 |
|
(let (entry high low nlist2) |
523 |
|
(if (eq ranges 'all) |
524 |
|
(setq ranges `((1 . ,(caar nlist))))) |
525 |
|
(while ranges |
526 |
|
(setq entry (car ranges) ranges (cdr ranges)) |
527 |
|
(while (and ranges (eq entry (car ranges))) |
528 |
|
(setq ranges (cdr ranges))) ;; skip duplicates |
529 |
|
(if (numberp entry) |
530 |
|
(setq low entry |
531 |
|
high entry) |
532 |
|
(setq low (car entry) |
533 |
|
high (cdr entry))) |
534 |
|
(setq nlist2 nlist) ;; Don't assume any sorting of ranges |
535 |
|
(catch 'iterate-loop |
536 |
|
(while nlist2 |
537 |
|
(if (<= (caar nlist2) high) (throw 'iterate-loop nil)) |
538 |
|
(setq nlist2 (cdr nlist2)))) |
539 |
|
(catch 'iterate-loop |
540 |
|
(while nlist2 |
541 |
|
(setq entry (car nlist2) nlist2 (cdr nlist2)) |
542 |
|
(if (< (car entry) low) (throw 'iterate-loop nil)) |
543 |
|
(funcall func (cdr entry))))))) |
544 |
|
|
545 |
|
(defun nnmaildir--up2-1 (n) |
546 |
|
(if (zerop n) 1 (1- (lsh 1 (1+ (logb n)))))) |
547 |
|
|
548 |
|
(defun nnmaildir--system-name () |
549 |
|
(gnus-replace-in-string |
550 |
|
(gnus-replace-in-string |
551 |
|
(gnus-replace-in-string |
552 |
|
(system-name) |
553 |
|
"\\\\" "\\134" 'literal) |
554 |
|
"/" "\\057" 'literal) |
555 |
|
":" "\\072" 'literal)) |
556 |
|
|
557 |
|
(defun nnmaildir-request-type (group &optional article) |
558 |
|
'mail) |
559 |
|
|
560 |
|
(defun nnmaildir-status-message (&optional server) |
561 |
|
(nnmaildir--prepare server nil) |
562 |
|
(nnmaildir--srv-error nnmaildir--cur-server)) |
563 |
|
|
564 |
|
(defun nnmaildir-server-opened (&optional server) |
565 |
|
(and nnmaildir--cur-server |
566 |
|
(if server |
567 |
|
(string-equal server (nnmaildir--srv-address nnmaildir--cur-server)) |
568 |
|
t) |
569 |
|
(nnmaildir--srv-groups nnmaildir--cur-server) |
570 |
|
t)) |
571 |
|
|
572 |
|
(defun nnmaildir-open-server (server &optional defs) |
573 |
|
(let ((x server) |
574 |
|
dir size) |
575 |
|
(catch 'return |
576 |
|
(setq server (intern-soft x nnmaildir--servers)) |
577 |
|
(if server |
578 |
|
(and (setq server (symbol-value server)) |
579 |
|
(nnmaildir--srv-groups server) |
580 |
|
(setq nnmaildir--cur-server server) |
581 |
|
(throw 'return t)) |
582 |
|
(setq server (make-nnmaildir--srv :address x)) |
583 |
|
(let ((inhibit-quit t)) |
584 |
|
(set (intern x nnmaildir--servers) server))) |
585 |
|
(setq dir (assq 'directory defs)) |
586 |
|
(unless dir |
587 |
|
(setf (nnmaildir--srv-error server) |
588 |
|
"You must set \"directory\" in the select method") |
589 |
|
(throw 'return nil)) |
590 |
|
(setq dir (cadr dir) |
591 |
|
dir (eval dir) |
592 |
|
dir (expand-file-name dir) |
593 |
|
dir (file-name-as-directory dir)) |
594 |
|
(unless (file-exists-p dir) |
595 |
|
(setf (nnmaildir--srv-error server) (concat "No such directory: " dir)) |
596 |
|
(throw 'return nil)) |
597 |
|
(setf (nnmaildir--srv-dir server) dir) |
598 |
|
(setq x (assq 'directory-files defs)) |
599 |
|
(if (null x) |
600 |
|
(setq x (if nnheader-directory-files-is-safe 'directory-files |
601 |
|
'nnheader-directory-files-safe)) |
602 |
|
(setq x (cadr x)) |
603 |
|
(unless (functionp x) |
604 |
|
(setf (nnmaildir--srv-error server) |
605 |
|
(concat "Not a function: " (prin1-to-string x))) |
606 |
|
(throw 'return nil))) |
607 |
|
(setf (nnmaildir--srv-ls server) x) |
608 |
|
(setq size (length (funcall x dir nil "\\`[^.]" 'nosort)) |
609 |
|
size (nnmaildir--up2-1 size)) |
610 |
|
(and (setq x (assq 'get-new-mail defs)) |
611 |
|
(setq x (cdr x)) |
612 |
|
(car x) |
613 |
|
(setf (nnmaildir--srv-gnm server) t) |
614 |
|
(require 'nnmail)) |
615 |
|
(setq x (assq 'target-prefix defs)) |
616 |
|
(if x |
617 |
|
(progn |
618 |
|
(setq x (cadr x) |
619 |
|
x (eval x)) |
620 |
|
(setf (nnmaildir--srv-target-prefix server) x)) |
621 |
|
(setq x (assq 'create-directory defs)) |
622 |
|
(if x |
623 |
|
(progn |
624 |
|
(setq x (cadr x) |
625 |
|
x (eval x) |
626 |
|
x (file-name-as-directory x)) |
627 |
|
(setf (nnmaildir--srv-target-prefix server) x)) |
628 |
|
(setf (nnmaildir--srv-target-prefix server) ""))) |
629 |
|
(setf (nnmaildir--srv-groups server) (make-vector size 0)) |
630 |
|
(setq nnmaildir--cur-server server) |
631 |
|
t))) |
632 |
|
|
633 |
|
(defun nnmaildir--parse-filename (file) |
634 |
|
(let ((prefix (car file)) |
635 |
|
timestamp len) |
636 |
|
(if (string-match "\\`\\([0-9]+\\)\\(\\..*\\)\\'" prefix) |
637 |
|
(progn |
638 |
|
(setq timestamp (concat "0000" (match-string 1 prefix)) |
639 |
|
len (- (length timestamp) 4)) |
640 |
|
(vector (string-to-number (substring timestamp 0 len)) |
641 |
|
(string-to-number (substring timestamp len)) |
642 |
|
(match-string 2 prefix) |
643 |
|
file)) |
644 |
|
file))) |
645 |
|
|
646 |
|
(defun nnmaildir--sort-files (a b) |
647 |
|
(catch 'return |
648 |
|
(if (consp a) |
649 |
|
(throw 'return (and (consp b) (string-lessp (car a) (car b))))) |
650 |
|
(if (consp b) (throw 'return t)) |
651 |
|
(if (< (aref a 0) (aref b 0)) (throw 'return t)) |
652 |
|
(if (> (aref a 0) (aref b 0)) (throw 'return nil)) |
653 |
|
(if (< (aref a 1) (aref b 1)) (throw 'return t)) |
654 |
|
(if (> (aref a 1) (aref b 1)) (throw 'return nil)) |
655 |
|
(string-lessp (aref a 2) (aref b 2)))) |
656 |
|
|
657 |
|
(defun nnmaildir--scan (gname scan-msgs groups method srv-dir srv-ls) |
658 |
|
(catch 'return |
659 |
|
(let ((36h-ago (- (car (current-time)) 2)) |
660 |
|
absdir nndir tdir ndir cdir nattr cattr isnew pgname read-only ls |
661 |
|
files num dir flist group x) |
662 |
|
(setq absdir (nnmaildir--srvgrp-dir srv-dir gname) |
663 |
|
nndir (nnmaildir--nndir absdir)) |
664 |
|
(unless (file-exists-p absdir) |
665 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
666 |
|
(concat "No such directory: " absdir)) |
667 |
|
(throw 'return nil)) |
668 |
|
(setq tdir (nnmaildir--tmp absdir) |
669 |
|
ndir (nnmaildir--new absdir) |
670 |
|
cdir (nnmaildir--cur absdir) |
671 |
|
nattr (file-attributes ndir) |
672 |
|
cattr (file-attributes cdir)) |
673 |
|
(unless (and (file-exists-p tdir) nattr cattr) |
674 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
675 |
|
(concat "Not a maildir: " absdir)) |
676 |
|
(throw 'return nil)) |
677 |
|
(setq group (nnmaildir--prepare nil gname) |
678 |
|
pgname (nnmaildir--pgname nnmaildir--cur-server gname)) |
679 |
|
(if group |
680 |
|
(setq isnew nil) |
681 |
|
(setq isnew t |
682 |
|
group (make-nnmaildir--grp :name gname :index 0)) |
683 |
|
(nnmaildir--mkdir nndir) |
684 |
|
(nnmaildir--mkdir (nnmaildir--nov-dir nndir)) |
685 |
|
(nnmaildir--mkdir (nnmaildir--marks-dir nndir)) |
686 |
|
(write-region "" nil (concat nndir "markfile") nil 'no-message)) |
687 |
|
(setq read-only (nnmaildir--param pgname 'read-only) |
688 |
|
ls (or (nnmaildir--param pgname 'directory-files) srv-ls)) |
689 |
|
(unless read-only |
690 |
|
(setq x (nth 11 (file-attributes tdir))) |
691 |
|
(unless (and (= x (nth 11 nattr)) (= x (nth 11 cattr))) |
692 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
693 |
|
(concat "Maildir spans filesystems: " absdir)) |
694 |
|
(throw 'return nil)) |
695 |
|
(mapcar |
696 |
|
(lambda (file) |
697 |
|
(setq x (file-attributes file)) |
698 |
|
(if (or (> (cadr x) 1) (< (car (nth 4 x)) 36h-ago)) |
699 |
|
(delete-file file))) |
700 |
|
(funcall ls tdir 'full "\\`[^.]" 'nosort))) |
701 |
|
(or scan-msgs |
702 |
|
isnew |
703 |
|
(throw 'return t)) |
704 |
|
(setq nattr (nth 5 nattr)) |
705 |
|
(if (equal nattr (nnmaildir--grp-new group)) |
706 |
|
(setq nattr nil)) |
707 |
|
(if read-only (setq dir (and (or isnew nattr) ndir)) |
708 |
|
(when (or isnew nattr) |
709 |
|
(mapcar |
710 |
|
(lambda (file) |
711 |
|
(let ((path (concat ndir file))) |
712 |
|
(and (time-less-p (nth 5 (file-attributes path)) (current-time)) |
713 |
|
(rename-file path (concat cdir file ":2,"))))) |
714 |
|
(funcall ls ndir nil "\\`[^.]" 'nosort)) |
715 |
|
(setf (nnmaildir--grp-new group) nattr)) |
716 |
|
(setq cattr (nth 5 (file-attributes cdir))) |
717 |
|
(if (equal cattr (nnmaildir--grp-cur group)) |
718 |
|
(setq cattr nil)) |
719 |
|
(setq dir (and (or isnew cattr) cdir))) |
720 |
|
(unless dir (throw 'return t)) |
721 |
|
(setq files (funcall ls dir nil "\\`[^.]" 'nosort) |
722 |
|
files (save-match-data |
723 |
|
(mapcar |
724 |
|
(lambda (f) |
725 |
|
(string-match "\\`\\([^:]*\\)\\(\\(:.*\\)?\\)\\'" f) |
726 |
|
(cons (match-string 1 f) (match-string 2 f))) |
727 |
|
files))) |
728 |
|
(when isnew |
729 |
|
(setq num (nnmaildir--up2-1 (length files))) |
730 |
|
(setf (nnmaildir--grp-flist group) (make-vector num 0)) |
731 |
|
(setf (nnmaildir--grp-mlist group) (make-vector num 0)) |
732 |
|
(setf (nnmaildir--grp-mmth group) (make-vector 1 0)) |
733 |
|
(setq num (nnmaildir--param pgname 'nov-cache-size)) |
734 |
|
(if (numberp num) (if (< num 1) (setq num 1)) |
735 |
|
(setq num 16 |
736 |
|
cdir (nnmaildir--marks-dir nndir) |
737 |
|
ndir (nnmaildir--subdir cdir "tick") |
738 |
|
cdir (nnmaildir--subdir cdir "read")) |
739 |
|
(mapcar |
740 |
|
(lambda (file) |
741 |
|
(setq file (car file)) |
742 |
|
(if (or (not (file-exists-p (concat cdir file))) |
743 |
|
(file-exists-p (concat ndir file))) |
744 |
|
(setq num (1+ num)))) |
745 |
|
files)) |
746 |
|
(setf (nnmaildir--grp-cache group) (make-vector num nil)) |
747 |
|
(let ((inhibit-quit t)) |
748 |
|
(set (intern gname groups) group)) |
749 |
|
(or scan-msgs (throw 'return t))) |
750 |
|
(setq flist (nnmaildir--grp-flist group) |
751 |
|
files (mapcar |
752 |
|
(lambda (file) |
753 |
|
(and (null (nnmaildir--flist-art flist (car file))) |
754 |
|
file)) |
755 |
|
files) |
756 |
|
files (delq nil files) |
757 |
|
files (mapcar 'nnmaildir--parse-filename files) |
758 |
|
files (sort files 'nnmaildir--sort-files)) |
759 |
|
(mapcar |
760 |
|
(lambda (file) |
761 |
|
(setq file (if (consp file) file (aref file 3)) |
762 |
|
x (make-nnmaildir--art :prefix (car file) :suffix (cdr file))) |
763 |
|
(nnmaildir--grp-add-art nnmaildir--cur-server group x)) |
764 |
|
files) |
765 |
|
(if read-only (setf (nnmaildir--grp-new group) nattr) |
766 |
|
(setf (nnmaildir--grp-cur group) cattr))) |
767 |
|
t)) |
768 |
|
|
769 |
|
(defun nnmaildir-request-scan (&optional scan-group server) |
770 |
|
(let ((coding-system-for-write nnheader-file-coding-system) |
771 |
|
(buffer-file-coding-system nil) |
772 |
|
(file-coding-system-alist nil) |
773 |
|
(nnmaildir-get-new-mail t) |
774 |
|
(nnmaildir-group-alist nil) |
775 |
|
(nnmaildir-active-file nil) |
776 |
|
x srv-ls srv-dir method groups target-prefix group dirs grp-dir seen |
777 |
|
deactivate-mark) |
778 |
|
(nnmaildir--prepare server nil) |
779 |
|
(setq srv-ls (nnmaildir--srv-ls nnmaildir--cur-server) |
780 |
|
srv-dir (nnmaildir--srv-dir nnmaildir--cur-server) |
781 |
|
method (nnmaildir--srv-method nnmaildir--cur-server) |
782 |
|
groups (nnmaildir--srv-groups nnmaildir--cur-server) |
783 |
|
target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server)) |
784 |
|
(nnmaildir--with-work-buffer |
785 |
|
(save-match-data |
786 |
|
(if (stringp scan-group) |
787 |
|
(if (nnmaildir--scan scan-group t groups method srv-dir srv-ls) |
788 |
|
(if (nnmaildir--srv-gnm nnmaildir--cur-server) |
789 |
|
(nnmail-get-new-mail 'nnmaildir nil nil scan-group)) |
790 |
|
(unintern scan-group groups)) |
791 |
|
(setq x (nth 5 (file-attributes srv-dir)) |
792 |
|
scan-group (null scan-group)) |
793 |
|
(if (equal x (nnmaildir--srv-mtime nnmaildir--cur-server)) |
794 |
|
(if scan-group |
795 |
|
(mapatoms (lambda (sym) |
796 |
|
(nnmaildir--scan (symbol-name sym) t groups |
797 |
|
method srv-dir srv-ls)) |
798 |
|
groups)) |
799 |
|
(setq dirs (funcall srv-ls srv-dir nil "\\`[^.]" 'nosort) |
800 |
|
dirs (if (zerop (length target-prefix)) |
801 |
|
dirs |
802 |
|
(gnus-remove-if |
803 |
|
(lambda (dir) |
804 |
|
(and (>= (length dir) (length target-prefix)) |
805 |
|
(string= (substring dir 0 |
806 |
|
(length target-prefix)) |
807 |
|
target-prefix))) |
808 |
|
dirs)) |
809 |
|
seen (nnmaildir--up2-1 (length dirs)) |
810 |
|
seen (make-vector seen 0)) |
811 |
|
(mapcar |
812 |
|
(lambda (grp-dir) |
813 |
|
(if (nnmaildir--scan grp-dir scan-group groups method srv-dir |
814 |
|
srv-ls) |
815 |
|
(intern grp-dir seen))) |
816 |
|
dirs) |
817 |
|
(setq x nil) |
818 |
|
(mapatoms (lambda (group) |
819 |
|
(setq group (symbol-name group)) |
820 |
|
(unless (intern-soft group seen) |
821 |
|
(setq x (cons group x)))) |
822 |
|
groups) |
823 |
|
(mapcar (lambda (grp) (unintern grp groups)) x) |
824 |
|
(setf (nnmaildir--srv-mtime nnmaildir--cur-server) |
825 |
|
(nth 5 (file-attributes srv-dir)))) |
826 |
|
(and scan-group |
827 |
|
(nnmaildir--srv-gnm nnmaildir--cur-server) |
828 |
|
(nnmail-get-new-mail 'nnmaildir nil nil)))))) |
829 |
|
t) |
830 |
|
|
831 |
|
(defun nnmaildir-request-list (&optional server) |
832 |
|
(nnmaildir-request-scan 'find-new-groups server) |
833 |
|
(let (pgname ro deactivate-mark) |
834 |
|
(nnmaildir--prepare server nil) |
835 |
|
(nnmaildir--with-nntp-buffer |
836 |
|
(erase-buffer) |
837 |
|
(mapatoms (lambda (group) |
838 |
|
(setq pgname (symbol-name group) |
839 |
|
pgname (nnmaildir--pgname nnmaildir--cur-server pgname) |
840 |
|
group (symbol-value group) |
841 |
|
ro (nnmaildir--param pgname 'read-only)) |
842 |
|
(insert (nnmaildir--grp-name group) " ") |
843 |
|
(princ (nnmaildir--group-maxnum nnmaildir--cur-server group) |
844 |
|
nntp-server-buffer) |
845 |
|
(insert " ") |
846 |
|
(princ (nnmaildir--grp-min group) nntp-server-buffer) |
847 |
|
(insert " " (if ro "n" "y") "\n")) |
848 |
|
(nnmaildir--srv-groups nnmaildir--cur-server)))) |
849 |
|
t) |
850 |
|
|
851 |
|
(defun nnmaildir-request-newgroups (date &optional server) |
852 |
|
(nnmaildir-request-list server)) |
853 |
|
|
854 |
|
(defun nnmaildir-retrieve-groups (groups &optional server) |
855 |
|
(let (group deactivate-mark) |
856 |
|
(nnmaildir--prepare server nil) |
857 |
|
(nnmaildir--with-nntp-buffer |
858 |
|
(erase-buffer) |
859 |
|
(mapcar |
860 |
|
(lambda (gname) |
861 |
|
(setq group (nnmaildir--prepare nil gname)) |
862 |
|
(if (null group) (insert "411 no such news group\n") |
863 |
|
(insert "211 ") |
864 |
|
(princ (nnmaildir--grp-count group) nntp-server-buffer) |
865 |
|
(insert " ") |
866 |
|
(princ (nnmaildir--grp-min group) nntp-server-buffer) |
867 |
|
(insert " ") |
868 |
|
(princ (nnmaildir--group-maxnum nnmaildir--cur-server group) |
869 |
|
nntp-server-buffer) |
870 |
|
(insert " " gname "\n"))) |
871 |
|
groups))) |
872 |
|
'group) |
873 |
|
|
874 |
|
(defun nnmaildir-request-update-info (gname info &optional server) |
875 |
|
(let ((group (nnmaildir--prepare server gname)) |
876 |
|
pgname flist always-marks never-marks old-marks dotfile num dir |
877 |
|
markdirs marks mark ranges markdir article read end new-marks ls |
878 |
|
old-mmth new-mmth mtime mark-sym existing missing deactivate-mark) |
879 |
|
(catch 'return |
880 |
|
(unless group |
881 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
882 |
|
(concat "No such group: " gname)) |
883 |
|
(throw 'return nil)) |
884 |
|
(setq gname (nnmaildir--grp-name group) |
885 |
|
pgname (nnmaildir--pgname nnmaildir--cur-server gname) |
886 |
|
flist (nnmaildir--grp-flist group)) |
887 |
|
(when (zerop (nnmaildir--grp-count group)) |
888 |
|
(gnus-info-set-read info nil) |
889 |
|
(gnus-info-set-marks info nil 'extend) |
890 |
|
(throw 'return info)) |
891 |
|
(setq old-marks (cons 'read (gnus-info-read info)) |
892 |
|
old-marks (cons old-marks (gnus-info-marks info)) |
893 |
|
always-marks (nnmaildir--param pgname 'always-marks) |
894 |
|
never-marks (nnmaildir--param pgname 'never-marks) |
895 |
|
existing (nnmaildir--grp-nlist group) |
896 |
|
existing (mapcar 'car existing) |
897 |
|
existing (nreverse existing) |
898 |
|
existing (gnus-compress-sequence existing 'always-list) |
899 |
|
missing (list (cons 1 (nnmaildir--group-maxnum |
900 |
|
nnmaildir--cur-server group))) |
901 |
|
missing (gnus-range-difference missing existing) |
902 |
|
dir (nnmaildir--srv-dir nnmaildir--cur-server) |
903 |
|
dir (nnmaildir--srvgrp-dir dir gname) |
904 |
|
dir (nnmaildir--nndir dir) |
905 |
|
dir (nnmaildir--marks-dir dir) |
906 |
|
ls (nnmaildir--group-ls nnmaildir--cur-server pgname) |
907 |
|
markdirs (funcall ls dir nil "\\`[^.]" 'nosort) |
908 |
|
new-mmth (nnmaildir--up2-1 (length markdirs)) |
909 |
|
new-mmth (make-vector new-mmth 0) |
910 |
|
old-mmth (nnmaildir--grp-mmth group)) |
911 |
|
(mapcar |
912 |
|
(lambda (mark) |
913 |
|
(setq markdir (nnmaildir--subdir dir mark) |
914 |
|
mark-sym (intern mark) |
915 |
|
ranges nil) |
916 |
|
(catch 'got-ranges |
917 |
|
(if (memq mark-sym never-marks) (throw 'got-ranges nil)) |
918 |
|
(when (memq mark-sym always-marks) |
919 |
|
(setq ranges existing) |
920 |
|
(throw 'got-ranges nil)) |
921 |
|
(setq mtime (nth 5 (file-attributes markdir))) |
922 |
|
(set (intern mark new-mmth) mtime) |
923 |
|
(when (equal mtime (symbol-value (intern-soft mark old-mmth))) |
924 |
|
(setq ranges (assq mark-sym old-marks)) |
925 |
|
(if ranges (setq ranges (cdr ranges))) |
926 |
|
(throw 'got-ranges nil)) |
927 |
|
(mapcar |
928 |
|
(lambda (prefix) |
929 |
|
(setq article (nnmaildir--flist-art flist prefix)) |
930 |
|
(if article |
931 |
|
(setq ranges |
932 |
|
(gnus-add-to-range ranges |
933 |
|
`(,(nnmaildir--art-num article)))))) |
934 |
|
(funcall ls markdir nil "\\`[^.]" 'nosort))) |
935 |
|
(if (eq mark-sym 'read) (setq read ranges) |
936 |
|
(if ranges (setq marks (cons (cons mark-sym ranges) marks))))) |
937 |
|
markdirs) |
938 |
|
(gnus-info-set-read info (gnus-range-add read missing)) |
939 |
|
(gnus-info-set-marks info marks 'extend) |
940 |
|
(setf (nnmaildir--grp-mmth group) new-mmth) |
941 |
|
info))) |
942 |
|
|
943 |
|
(defun nnmaildir-request-group (gname &optional server fast) |
944 |
|
(let ((group (nnmaildir--prepare server gname)) |
945 |
|
deactivate-mark) |
946 |
|
(catch 'return |
947 |
|
(unless group |
948 |
|
;; (insert "411 no such news group\n") |
949 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
950 |
|
(concat "No such group: " gname)) |
951 |
|
(throw 'return nil)) |
952 |
|
(setf (nnmaildir--srv-curgrp nnmaildir--cur-server) group) |
953 |
|
(if fast (throw 'return t)) |
954 |
|
(nnmaildir--with-nntp-buffer |
955 |
|
(erase-buffer) |
956 |
|
(insert "211 ") |
957 |
|
(princ (nnmaildir--grp-count group) nntp-server-buffer) |
958 |
|
(insert " ") |
959 |
|
(princ (nnmaildir--grp-min group) nntp-server-buffer) |
960 |
|
(insert " ") |
961 |
|
(princ (nnmaildir--group-maxnum nnmaildir--cur-server group) |
962 |
|
nntp-server-buffer) |
963 |
|
(insert " " gname "\n") |
964 |
|
t)))) |
965 |
|
|
966 |
|
(defun nnmaildir-request-create-group (gname &optional server args) |
967 |
|
(nnmaildir--prepare server nil) |
968 |
|
(catch 'return |
969 |
|
(let ((target-prefix (nnmaildir--srv-target-prefix nnmaildir--cur-server)) |
970 |
|
srv-dir dir groups) |
971 |
|
(when (zerop (length gname)) |
972 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
973 |
|
"Invalid (empty) group name") |
974 |
|
(throw 'return nil)) |
975 |
|
(when (eq (aref "." 0) (aref gname 0)) |
976 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
977 |
|
"Group names may not start with \".\"") |
978 |
|
(throw 'return nil)) |
979 |
|
(when (save-match-data (string-match "[\0/\t]" gname)) |
980 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
981 |
|
(concat "Illegal characters (null, tab, or /) in group name: " |
982 |
|
gname)) |
983 |
|
(throw 'return nil)) |
984 |
|
(setq groups (nnmaildir--srv-groups nnmaildir--cur-server)) |
985 |
|
(when (intern-soft gname groups) |
986 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
987 |
|
(concat "Group already exists: " gname)) |
988 |
|
(throw 'return nil)) |
989 |
|
(setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)) |
990 |
|
(if (file-name-absolute-p target-prefix) |
991 |
|
(setq dir (expand-file-name target-prefix)) |
992 |
|
(setq dir srv-dir |
993 |
|
dir (file-truename dir) |
994 |
|
dir (concat dir target-prefix))) |
995 |
|
(setq dir (nnmaildir--subdir dir gname)) |
996 |
|
(nnmaildir--mkdir dir) |
997 |
|
(nnmaildir--mkdir (nnmaildir--tmp dir)) |
998 |
|
(nnmaildir--mkdir (nnmaildir--new dir)) |
999 |
|
(nnmaildir--mkdir (nnmaildir--cur dir)) |
1000 |
|
(unless (string= target-prefix "") |
1001 |
|
(make-symbolic-link (concat target-prefix gname) |
1002 |
|
(concat srv-dir gname))) |
1003 |
|
(nnmaildir-request-scan 'find-new-groups)))) |
1004 |
|
|
1005 |
|
(defun nnmaildir-request-rename-group (gname new-name &optional server) |
1006 |
|
(let ((group (nnmaildir--prepare server gname)) |
1007 |
|
(coding-system-for-write nnheader-file-coding-system) |
1008 |
|
(buffer-file-coding-system nil) |
1009 |
|
(file-coding-system-alist nil) |
1010 |
|
srv-dir x groups) |
1011 |
|
(catch 'return |
1012 |
|
(unless group |
1013 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1014 |
|
(concat "No such group: " gname)) |
1015 |
|
(throw 'return nil)) |
1016 |
|
(when (zerop (length new-name)) |
1017 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1018 |
|
"Invalid (empty) group name") |
1019 |
|
(throw 'return nil)) |
1020 |
|
(when (eq (aref "." 0) (aref new-name 0)) |
1021 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1022 |
|
"Group names may not start with \".\"") |
1023 |
|
(throw 'return nil)) |
1024 |
|
(when (save-match-data (string-match "[\0/\t]" new-name)) |
1025 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1026 |
|
(concat "Illegal characters (null, tab, or /) in group name: " |
1027 |
|
new-name)) |
1028 |
|
(throw 'return nil)) |
1029 |
|
(if (string-equal gname new-name) (throw 'return t)) |
1030 |
|
(when (intern-soft new-name |
1031 |
|
(nnmaildir--srv-groups nnmaildir--cur-server)) |
1032 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1033 |
|
(concat "Group already exists: " new-name)) |
1034 |
|
(throw 'return nil)) |
1035 |
|
(setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server)) |
1036 |
|
(condition-case err |
1037 |
|
(rename-file (concat srv-dir gname) |
1038 |
|
(concat srv-dir new-name)) |
1039 |
|
(error |
1040 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1041 |
|
(concat "Error renaming link: " (prin1-to-string err))) |
1042 |
|
(throw 'return nil))) |
1043 |
|
(setq x (nnmaildir--srv-groups nnmaildir--cur-server) |
1044 |
|
groups (make-vector (length x) 0)) |
1045 |
|
(mapatoms (lambda (sym) |
1046 |
|
(unless (eq (symbol-value sym) group) |
1047 |
|
(set (intern (symbol-name sym) groups) |
1048 |
|
(symbol-value sym)))) |
1049 |
|
x) |
1050 |
|
(setq group (copy-sequence group)) |
1051 |
|
(setf (nnmaildir--grp-name group) new-name) |
1052 |
|
(set (intern new-name groups) group) |
1053 |
|
(setf (nnmaildir--srv-groups nnmaildir--cur-server) groups) |
1054 |
|
t))) |
1055 |
|
|
1056 |
|
(defun nnmaildir-request-delete-group (gname force &optional server) |
1057 |
|
(let ((group (nnmaildir--prepare server gname)) |
1058 |
|
pgname grp-dir target dir ls deactivate-mark) |
1059 |
|
(catch 'return |
1060 |
|
(unless group |
1061 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1062 |
|
(concat "No such group: " gname)) |
1063 |
|
(throw 'return nil)) |
1064 |
|
(setq gname (nnmaildir--grp-name group) |
1065 |
|
pgname (nnmaildir--pgname nnmaildir--cur-server gname) |
1066 |
|
grp-dir (nnmaildir--srv-dir nnmaildir--cur-server) |
1067 |
|
target (car (file-attributes (concat grp-dir gname))) |
1068 |
|
grp-dir (nnmaildir--srvgrp-dir grp-dir gname)) |
1069 |
|
(unless (or force (stringp target)) |
1070 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1071 |
|
(concat "Not a symlink: " gname)) |
1072 |
|
(throw 'return nil)) |
1073 |
|
(if (eq group (nnmaildir--srv-curgrp nnmaildir--cur-server)) |
1074 |
|
(setf (nnmaildir--srv-curgrp nnmaildir--cur-server) nil)) |
1075 |
|
(unintern gname (nnmaildir--srv-groups nnmaildir--cur-server)) |
1076 |
|
(if (not force) |
1077 |
|
(progn |
1078 |
|
(setq grp-dir (directory-file-name grp-dir)) |
1079 |
|
(nnmaildir--unlink grp-dir)) |
1080 |
|
(setq ls (nnmaildir--group-ls nnmaildir--cur-server pgname)) |
1081 |
|
(if (nnmaildir--param pgname 'read-only) |
1082 |
|
(progn (delete-directory (nnmaildir--tmp grp-dir)) |
1083 |
|
(nnmaildir--unlink (nnmaildir--new grp-dir)) |
1084 |
|
(delete-directory (nnmaildir--cur grp-dir))) |
1085 |
|
(nnmaildir--delete-dir-files (nnmaildir--tmp grp-dir) ls) |
1086 |
|
(nnmaildir--delete-dir-files (nnmaildir--new grp-dir) ls) |
1087 |
|
(nnmaildir--delete-dir-files (nnmaildir--cur grp-dir) ls)) |
1088 |
|
(setq dir (nnmaildir--nndir grp-dir)) |
1089 |
|
(mapcar (lambda (subdir) (nnmaildir--delete-dir-files subdir ls)) |
1090 |
|
`(,(nnmaildir--nov-dir dir) ,(nnmaildir--num-dir dir) |
1091 |
|
,@(funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]" |
1092 |
|
'nosort))) |
1093 |
|
(setq dir (nnmaildir--nndir grp-dir)) |
1094 |
|
(nnmaildir--unlink (concat dir "markfile")) |
1095 |
|
(nnmaildir--unlink (concat dir "markfile{new}")) |
1096 |
|
(delete-directory (nnmaildir--marks-dir dir)) |
1097 |
|
(delete-directory dir) |
1098 |
|
(if (not (stringp target)) |
1099 |
|
(delete-directory grp-dir) |
1100 |
|
(setq grp-dir (directory-file-name grp-dir) |
1101 |
|
dir target) |
1102 |
|
(unless (eq (aref "/" 0) (aref dir 0)) |
1103 |
|
(setq dir (concat (file-truename |
1104 |
|
(nnmaildir--srv-dir nnmaildir--cur-server)) |
1105 |
|
dir))) |
1106 |
|
(delete-directory dir) |
1107 |
|
(nnmaildir--unlink grp-dir))) |
1108 |
|
t))) |
1109 |
|
|
1110 |
|
(defun nnmaildir-retrieve-headers (articles &optional gname server fetch-old) |
1111 |
|
(let ((group (nnmaildir--prepare server gname)) |
1112 |
|
srv-dir dir nlist mlist article num start stop nov nlist2 insert-nov |
1113 |
|
deactivate-mark) |
1114 |
|
(setq insert-nov |
1115 |
|
(lambda (article) |
1116 |
|
(setq nov (nnmaildir--update-nov nnmaildir--cur-server group |
1117 |
|
article)) |
1118 |
|
(when nov |
1119 |
|
(nnmaildir--cache-nov group article nov) |
1120 |
|
(setq num (nnmaildir--art-num article)) |
1121 |
|
(princ num nntp-server-buffer) |
1122 |
|
(insert "\t" (nnmaildir--nov-get-beg nov) "\t" |
1123 |
|
(nnmaildir--art-msgid article) "\t" |
1124 |
|
(nnmaildir--nov-get-mid nov) "\tXref: nnmaildir " |
1125 |
|
gname ":") |
1126 |
|
(princ num nntp-server-buffer) |
1127 |
|
(insert "\t" (nnmaildir--nov-get-end nov) "\n")))) |
1128 |
|
(catch 'return |
1129 |
|
(unless group |
1130 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1131 |
|
(if gname (concat "No such group: " gname) "No current group")) |
1132 |
|
(throw 'return nil)) |
1133 |
|
(nnmaildir--with-nntp-buffer |
1134 |
|
(erase-buffer) |
1135 |
|
(setq mlist (nnmaildir--grp-mlist group) |
1136 |
|
nlist (nnmaildir--grp-nlist group) |
1137 |
|
gname (nnmaildir--grp-name group) |
1138 |
|
srv-dir (nnmaildir--srv-dir nnmaildir--cur-server) |
1139 |
|
dir (nnmaildir--srvgrp-dir srv-dir gname)) |
1140 |
|
(cond |
1141 |
|
((null nlist)) |
1142 |
|
((and fetch-old (not (numberp fetch-old))) |
1143 |
|
(nnmaildir--nlist-iterate nlist 'all insert-nov)) |
1144 |
|
((null articles)) |
1145 |
|
((stringp (car articles)) |
1146 |
|
(mapcar |
1147 |
|
(lambda (msgid) |
1148 |
|
(setq article (nnmaildir--mlist-art mlist msgid)) |
1149 |
|
(if article (funcall insert-nov article))) |
1150 |
|
articles)) |
1151 |
|
(t |
1152 |
|
(if fetch-old |
1153 |
|
;; Assume the article range list is sorted ascending |
1154 |
|
(setq stop (car articles) |
1155 |
|
start (car (last articles)) |
1156 |
|
stop (if (numberp stop) stop (car stop)) |
1157 |
|
start (if (numberp start) start (cdr start)) |
1158 |
|
stop (- stop fetch-old) |
1159 |
|
stop (if (< stop 1) 1 stop) |
1160 |
|
articles (list (cons stop start)))) |
1161 |
|
(nnmaildir--nlist-iterate nlist articles insert-nov))) |
1162 |
|
(sort-numeric-fields 1 (point-min) (point-max)) |
1163 |
|
'nov)))) |
1164 |
|
|
1165 |
|
(defun nnmaildir-request-article (num-msgid &optional gname server to-buffer) |
1166 |
|
(let ((group (nnmaildir--prepare server gname)) |
1167 |
|
(case-fold-search t) |
1168 |
|
list article dir pgname deactivate-mark) |
1169 |
|
(catch 'return |
1170 |
|
(unless group |
1171 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1172 |
|
(if gname (concat "No such group: " gname) "No current group")) |
1173 |
|
(throw 'return nil)) |
1174 |
|
(if (numberp num-msgid) |
1175 |
|
(setq article (nnmaildir--nlist-art group num-msgid)) |
1176 |
|
(setq list (nnmaildir--grp-mlist group) |
1177 |
|
article (nnmaildir--mlist-art list num-msgid)) |
1178 |
|
(if article (setq num-msgid (nnmaildir--art-num article)) |
1179 |
|
(catch 'found |
1180 |
|
(mapatoms |
1181 |
|
(lambda (group-sym) |
1182 |
|
(setq group (symbol-value group-sym) |
1183 |
|
list (nnmaildir--grp-mlist group) |
1184 |
|
article (nnmaildir--mlist-art list num-msgid)) |
1185 |
|
(when article |
1186 |
|
(setq num-msgid (nnmaildir--art-num article)) |
1187 |
|
(throw 'found nil))) |
1188 |
|
(nnmaildir--srv-groups nnmaildir--cur-server)))) |
1189 |
|
(unless article |
1190 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article") |
1191 |
|
(throw 'return nil))) |
1192 |
|
(setq gname (nnmaildir--grp-name group) |
1193 |
|
pgname (nnmaildir--pgname nnmaildir--cur-server gname) |
1194 |
|
dir (nnmaildir--srv-dir nnmaildir--cur-server) |
1195 |
|
dir (nnmaildir--srvgrp-dir dir gname) |
1196 |
|
dir (if (nnmaildir--param pgname 'read-only) |
1197 |
|
(nnmaildir--new dir) (nnmaildir--cur dir)) |
1198 |
|
nnmaildir-article-file-name |
1199 |
|
(concat dir |
1200 |
|
(nnmaildir--art-prefix article) |
1201 |
|
(nnmaildir--art-suffix article))) |
1202 |
|
(unless (file-exists-p nnmaildir-article-file-name) |
1203 |
|
(nnmaildir--expired-article group article) |
1204 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1205 |
|
"Article has expired") |
1206 |
|
(throw 'return nil)) |
1207 |
|
(save-excursion |
1208 |
|
(set-buffer (or to-buffer nntp-server-buffer)) |
1209 |
|
(erase-buffer) |
1210 |
|
(nnheader-insert-file-contents nnmaildir-article-file-name)) |
1211 |
|
(cons gname num-msgid)))) |
1212 |
|
|
1213 |
|
(defun nnmaildir-request-post (&optional server) |
1214 |
|
(let (message-required-mail-headers) |
1215 |
|
(funcall message-send-mail-function))) |
1216 |
|
|
1217 |
|
(defun nnmaildir-request-replace-article (number gname buffer) |
1218 |
|
(let ((group (nnmaildir--prepare nil gname)) |
1219 |
|
(coding-system-for-write nnheader-file-coding-system) |
1220 |
|
(buffer-file-coding-system nil) |
1221 |
|
(file-coding-system-alist nil) |
1222 |
|
dir file article suffix tmpfile deactivate-mark) |
1223 |
|
(catch 'return |
1224 |
|
(unless group |
1225 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1226 |
|
(concat "No such group: " gname)) |
1227 |
|
(throw 'return nil)) |
1228 |
|
(when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname) |
1229 |
|
'read-only) |
1230 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1231 |
|
(concat "Read-only group: " group)) |
1232 |
|
(throw 'return nil)) |
1233 |
|
(setq dir (nnmaildir--srv-dir nnmaildir--cur-server) |
1234 |
|
dir (nnmaildir--srvgrp-dir dir gname) |
1235 |
|
article (nnmaildir--nlist-art group number)) |
1236 |
|
(unless article |
1237 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1238 |
|
(concat "No such article: " (number-to-string number))) |
1239 |
|
(throw 'return nil)) |
1240 |
|
(setq suffix (nnmaildir--art-suffix article) |
1241 |
|
file (nnmaildir--art-prefix article) |
1242 |
|
tmpfile (concat (nnmaildir--tmp dir) file)) |
1243 |
|
(when (file-exists-p tmpfile) |
1244 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1245 |
|
(concat "File exists: " tmpfile)) |
1246 |
|
(throw 'return nil)) |
1247 |
|
(save-excursion |
1248 |
|
(set-buffer buffer) |
1249 |
|
(write-region (point-min) (point-max) tmpfile nil 'no-message nil |
1250 |
|
'excl)) |
1251 |
|
(unix-sync) ;; no fsync :( |
1252 |
|
(rename-file tmpfile (concat (nnmaildir--cur dir) file suffix) 'replace) |
1253 |
|
t))) |
1254 |
|
|
1255 |
|
(defun nnmaildir-request-move-article (article gname server accept-form |
1256 |
|
&optional last) |
1257 |
|
(let ((group (nnmaildir--prepare server gname)) |
1258 |
|
pgname suffix result nnmaildir--file deactivate-mark) |
1259 |
|
(catch 'return |
1260 |
|
(unless group |
1261 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1262 |
|
(concat "No such group: " gname)) |
1263 |
|
(throw 'return nil)) |
1264 |
|
(setq gname (nnmaildir--grp-name group) |
1265 |
|
pgname (nnmaildir--pgname nnmaildir--cur-server gname) |
1266 |
|
article (nnmaildir--nlist-art group article)) |
1267 |
|
(unless article |
1268 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) "No such article") |
1269 |
|
(throw 'return nil)) |
1270 |
|
(setq suffix (nnmaildir--art-suffix article) |
1271 |
|
nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server) |
1272 |
|
nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname) |
1273 |
|
nnmaildir--file (if (nnmaildir--param pgname 'read-only) |
1274 |
|
(nnmaildir--new nnmaildir--file) |
1275 |
|
(nnmaildir--cur nnmaildir--file)) |
1276 |
|
nnmaildir--file (concat nnmaildir--file |
1277 |
|
(nnmaildir--art-prefix article) |
1278 |
|
suffix)) |
1279 |
|
(unless (file-exists-p nnmaildir--file) |
1280 |
|
(nnmaildir--expired-article group article) |
1281 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1282 |
|
"Article has expired") |
1283 |
|
(throw 'return nil)) |
1284 |
|
(nnmaildir--with-move-buffer |
1285 |
|
(erase-buffer) |
1286 |
|
(nnheader-insert-file-contents nnmaildir--file) |
1287 |
|
(setq result (eval accept-form))) |
1288 |
|
(unless (or (null result) (nnmaildir--param pgname 'read-only)) |
1289 |
|
(nnmaildir--unlink nnmaildir--file) |
1290 |
|
(nnmaildir--expired-article group article)) |
1291 |
|
result))) |
1292 |
|
|
1293 |
|
(defun nnmaildir-request-accept-article (gname &optional server last) |
1294 |
|
(let ((group (nnmaildir--prepare server gname)) |
1295 |
|
(coding-system-for-write nnheader-file-coding-system) |
1296 |
|
(buffer-file-coding-system nil) |
1297 |
|
(file-coding-system-alist nil) |
1298 |
|
srv-dir dir file time tmpfile curfile 24h article) |
1299 |
|
(catch 'return |
1300 |
|
(unless group |
1301 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1302 |
|
(concat "No such group: " gname)) |
1303 |
|
(throw 'return nil)) |
1304 |
|
(setq gname (nnmaildir--grp-name group)) |
1305 |
|
(when (nnmaildir--param (nnmaildir--pgname nnmaildir--cur-server gname) |
1306 |
|
'read-only) |
1307 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1308 |
|
(concat "Read-only group: " gname)) |
1309 |
|
(throw 'return nil)) |
1310 |
|
(setq srv-dir (nnmaildir--srv-dir nnmaildir--cur-server) |
1311 |
|
dir (nnmaildir--srvgrp-dir srv-dir gname) |
1312 |
|
time (current-time) |
1313 |
|
file (format-time-string "%s." time)) |
1314 |
|
(unless (string-equal nnmaildir--delivery-time file) |
1315 |
|
(setq nnmaildir--delivery-time file |
1316 |
|
nnmaildir--delivery-count 0)) |
1317 |
|
(when (and (consp (cdr time)) |
1318 |
|
(consp (cddr time))) |
1319 |
|
(setq file (concat file "M" (number-to-string (caddr time))))) |
1320 |
|
(setq file (concat file nnmaildir--delivery-pid) |
1321 |
|
file (concat file "Q" (number-to-string nnmaildir--delivery-count)) |
1322 |
|
file (concat file "." (nnmaildir--system-name)) |
1323 |
|
tmpfile (concat (nnmaildir--tmp dir) file) |
1324 |
|
curfile (concat (nnmaildir--cur dir) file ":2,")) |
1325 |
|
(when (file-exists-p tmpfile) |
1326 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1327 |
|
(concat "File exists: " tmpfile)) |
1328 |
|
(throw 'return nil)) |
1329 |
|
(when (file-exists-p curfile) |
1330 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1331 |
|
(concat "File exists: " curfile)) |
1332 |
|
(throw 'return nil)) |
1333 |
|
(setq nnmaildir--delivery-count (1+ nnmaildir--delivery-count) |
1334 |
|
24h (run-with-timer 86400 nil |
1335 |
|
(lambda () |
1336 |
|
(nnmaildir--unlink tmpfile) |
1337 |
|
(setf (nnmaildir--srv-error |
1338 |
|
nnmaildir--cur-server) |
1339 |
|
"24-hour timer expired") |
1340 |
|
(throw 'return nil)))) |
1341 |
|
(condition-case nil |
1342 |
|
(add-name-to-file nnmaildir--file tmpfile) |
1343 |
|
(error |
1344 |
|
(write-region (point-min) (point-max) tmpfile nil 'no-message nil |
1345 |
|
'excl) |
1346 |
|
(unix-sync))) ;; no fsync :( |
1347 |
|
(cancel-timer 24h) |
1348 |
|
(condition-case err |
1349 |
|
(add-name-to-file tmpfile curfile) |
1350 |
|
(error |
1351 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1352 |
|
(concat "Error linking: " (prin1-to-string err))) |
1353 |
|
(nnmaildir--unlink tmpfile) |
1354 |
|
(throw 'return nil))) |
1355 |
|
(nnmaildir--unlink tmpfile) |
1356 |
|
(setq article (make-nnmaildir--art :prefix file :suffix ":2,")) |
1357 |
|
(if (nnmaildir--grp-add-art nnmaildir--cur-server group article) |
1358 |
|
(cons gname (nnmaildir--art-num article)))))) |
1359 |
|
|
1360 |
|
(defun nnmaildir-save-mail (group-art) |
1361 |
|
(catch 'return |
1362 |
|
(unless group-art |
1363 |
|
(throw 'return nil)) |
1364 |
|
(let (ga gname x groups nnmaildir--file deactivate-mark) |
1365 |
|
(save-excursion |
1366 |
|
(goto-char (point-min)) |
1367 |
|
(save-match-data |
1368 |
|
(while (looking-at "From ") |
1369 |
|
(replace-match "X-From-Line: ") |
1370 |
|
(forward-line 1)))) |
1371 |
|
(setq groups (nnmaildir--srv-groups nnmaildir--cur-server) |
1372 |
|
ga (car group-art) group-art (cdr group-art) |
1373 |
|
gname (car ga)) |
1374 |
|
(or (intern-soft gname groups) |
1375 |
|
(nnmaildir-request-create-group gname) |
1376 |
|
(throw 'return nil)) ;; not that nnmail bothers to check :( |
1377 |
|
(unless (nnmaildir-request-accept-article gname) |
1378 |
|
(throw 'return nil)) |
1379 |
|
(setq nnmaildir--file (nnmaildir--srv-dir nnmaildir--cur-server) |
1380 |
|
nnmaildir--file (nnmaildir--srvgrp-dir nnmaildir--file gname) |
1381 |
|
x (nnmaildir--prepare nil gname) |
1382 |
|
x (nnmaildir--grp-nlist x) |
1383 |
|
x (cdar x) |
1384 |
|
nnmaildir--file (concat nnmaildir--file |
1385 |
|
(nnmaildir--art-prefix x) |
1386 |
|
(nnmaildir--art-suffix x))) |
1387 |
|
(delq nil |
1388 |
|
(mapcar |
1389 |
|
(lambda (ga) |
1390 |
|
(setq gname (car ga)) |
1391 |
|
(and (or (intern-soft gname groups) |
1392 |
|
(nnmaildir-request-create-group gname)) |
1393 |
|
(nnmaildir-request-accept-article gname) |
1394 |
|
ga)) |
1395 |
|
group-art))))) |
1396 |
|
|
1397 |
|
(defun nnmaildir-active-number (gname) |
1398 |
|
0) |
1399 |
|
|
1400 |
|
(defun nnmaildir-request-expire-articles (ranges &optional gname server force) |
1401 |
|
(let ((no-force (not force)) |
1402 |
|
(group (nnmaildir--prepare server gname)) |
1403 |
|
pgname time boundary bound-iter high low target dir nlist nlist2 |
1404 |
|
stop article didnt nnmaildir--file nnmaildir-article-file-name |
1405 |
|
deactivate-mark) |
1406 |
|
(catch 'return |
1407 |
|
(unless group |
1408 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1409 |
|
(if gname (concat "No such group: " gname) "No current group")) |
1410 |
|
(throw 'return (gnus-uncompress-range ranges))) |
1411 |
|
(setq gname (nnmaildir--grp-name group) |
1412 |
|
pgname (nnmaildir--pgname nnmaildir--cur-server gname)) |
1413 |
|
(if (nnmaildir--param pgname 'read-only) |
1414 |
|
(throw 'return (gnus-uncompress-range ranges))) |
1415 |
|
(setq time (nnmaildir--param pgname 'expire-age)) |
1416 |
|
(unless time |
1417 |
|
(setq time (or (and nnmail-expiry-wait-function |
1418 |
|
(funcall nnmail-expiry-wait-function gname)) |
1419 |
|
nnmail-expiry-wait)) |
1420 |
|
(if (eq time 'immediate) |
1421 |
|
(setq time 0) |
1422 |
|
(if (numberp time) |
1423 |
|
(setq time (* time 86400))))) |
1424 |
|
(when no-force |
1425 |
|
(unless (integerp time) ;; handle 'never |
1426 |
|
(throw 'return (gnus-uncompress-range ranges))) |
1427 |
|
(setq boundary (current-time) |
1428 |
|
high (- (car boundary) (/ time 65536)) |
1429 |
|
low (- (cadr boundary) (% time 65536))) |
1430 |
|
(if (< low 0) |
1431 |
|
(setq low (+ low 65536) |
1432 |
|
high (1- high))) |
1433 |
|
(setcar (cdr boundary) low) |
1434 |
|
(setcar boundary high)) |
1435 |
|
(setq dir (nnmaildir--srv-dir nnmaildir--cur-server) |
1436 |
|
dir (nnmaildir--srvgrp-dir dir gname) |
1437 |
|
dir (nnmaildir--cur dir) |
1438 |
|
nlist (nnmaildir--grp-nlist group) |
1439 |
|
ranges (reverse ranges)) |
1440 |
|
(nnmaildir--with-move-buffer |
1441 |
|
(nnmaildir--nlist-iterate |
1442 |
|
nlist ranges |
1443 |
|
(lambda (article) |
1444 |
|
(setq nnmaildir--file (nnmaildir--art-prefix article) |
1445 |
|
nnmaildir--file (concat dir nnmaildir--file |
1446 |
|
(nnmaildir--art-suffix article)) |
1447 |
|
time (file-attributes nnmaildir--file)) |
1448 |
|
(cond |
1449 |
|
((null time) |
1450 |
|
(nnmaildir--expired-article group article)) |
1451 |
|
((and no-force |
1452 |
|
(progn |
1453 |
|
(setq time (nth 5 time) |
1454 |
|
bound-iter boundary) |
1455 |
|
(while (and bound-iter time |
1456 |
|
(= (car bound-iter) (car time))) |
1457 |
|
(setq bound-iter (cdr bound-iter) |
1458 |
|
time (cdr time))) |
1459 |
|
(and bound-iter time |
1460 |
|
(car-less-than-car bound-iter time)))) |
1461 |
|
(setq didnt (cons (nnmaildir--art-num article) didnt))) |
1462 |
|
(t |
1463 |
|
(setq nnmaildir-article-file-name nnmaildir--file |
1464 |
|
target (if force nil |
1465 |
|
(save-excursion |
1466 |
|
(save-restriction |
1467 |
|
(nnmaildir--param pgname 'expire-group))))) |
1468 |
|
(when (and (stringp target) |
1469 |
|
(not (string-equal target pgname))) ;; Move it. |
1470 |
|
(erase-buffer) |
1471 |
|
(nnheader-insert-file-contents nnmaildir--file) |
1472 |
|
(gnus-request-accept-article target nil nil 'no-encode)) |
1473 |
|
(if (equal target pgname) |
1474 |
|
;; Leave it here. |
1475 |
|
(setq didnt (cons (nnmaildir--art-num article) didnt)) |
1476 |
|
(nnmaildir--unlink nnmaildir--file) |
1477 |
|
(nnmaildir--expired-article group article)))))) |
1478 |
|
(erase-buffer)) |
1479 |
|
didnt))) |
1480 |
|
|
1481 |
|
(defun nnmaildir-request-set-mark (gname actions &optional server) |
1482 |
|
(let ((group (nnmaildir--prepare server gname)) |
1483 |
|
(coding-system-for-write nnheader-file-coding-system) |
1484 |
|
(buffer-file-coding-system nil) |
1485 |
|
(file-coding-system-alist nil) |
1486 |
|
del-mark del-action add-action set-action marksdir markfile nlist |
1487 |
|
ranges begin end article all-marks todo-marks did-marks mdir mfile |
1488 |
|
pgname ls permarkfile deactivate-mark) |
1489 |
|
(setq del-mark |
1490 |
|
(lambda (mark) |
1491 |
|
(setq mfile (nnmaildir--subdir marksdir (symbol-name mark)) |
1492 |
|
mfile (concat mfile (nnmaildir--art-prefix article))) |
1493 |
|
(nnmaildir--unlink mfile)) |
1494 |
|
del-action (lambda (article) (mapcar del-mark todo-marks)) |
1495 |
|
add-action |
1496 |
|
(lambda (article) |
1497 |
|
(mapcar |
1498 |
|
(lambda (mark) |
1499 |
|
(setq mdir (nnmaildir--subdir marksdir (symbol-name mark)) |
1500 |
|
permarkfile (concat mdir ":") |
1501 |
|
mfile (concat mdir (nnmaildir--art-prefix article))) |
1502 |
|
(unless (memq mark did-marks) |
1503 |
|
(setq did-marks (cons mark did-marks)) |
1504 |
|
(nnmaildir--mkdir mdir) |
1505 |
|
(unless (file-attributes permarkfile) |
1506 |
|
(condition-case nil |
1507 |
|
(add-name-to-file markfile permarkfile) |
1508 |
|
(file-error |
1509 |
|
;; AFS can't make hard links in separate directories |
1510 |
|
(write-region "" nil permarkfile nil 'no-message))))) |
1511 |
|
(unless (file-exists-p mfile) |
1512 |
|
(add-name-to-file permarkfile mfile))) |
1513 |
|
todo-marks)) |
1514 |
|
set-action (lambda (article) |
1515 |
|
(funcall add-action) |
1516 |
|
(mapcar (lambda (mark) |
1517 |
|
(unless (memq mark todo-marks) |
1518 |
|
(funcall del-mark mark))) |
1519 |
|
all-marks))) |
1520 |
|
(catch 'return |
1521 |
|
(unless group |
1522 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1523 |
|
(concat "No such group: " gname)) |
1524 |
|
(mapcar (lambda (action) |
1525 |
|
(setq ranges (gnus-range-add ranges (car action)))) |
1526 |
|
actions) |
1527 |
|
(throw 'return ranges)) |
1528 |
|
(setq nlist (nnmaildir--grp-nlist group) |
1529 |
|
marksdir (nnmaildir--srv-dir nnmaildir--cur-server) |
1530 |
|
marksdir (nnmaildir--srvgrp-dir marksdir gname) |
1531 |
|
marksdir (nnmaildir--nndir marksdir) |
1532 |
|
markfile (concat marksdir "markfile") |
1533 |
|
marksdir (nnmaildir--marks-dir marksdir) |
1534 |
|
gname (nnmaildir--grp-name group) |
1535 |
|
pgname (nnmaildir--pgname nnmaildir--cur-server gname) |
1536 |
|
ls (nnmaildir--group-ls nnmaildir--cur-server pgname) |
1537 |
|
all-marks (funcall ls marksdir nil "\\`[^.]" 'nosort) |
1538 |
|
all-marks (mapcar 'intern all-marks)) |
1539 |
|
(mapcar |
1540 |
|
(lambda (action) |
1541 |
|
(setq ranges (car action) |
1542 |
|
todo-marks (caddr action)) |
1543 |
|
(mapcar (lambda (mark) (add-to-list 'all-marks mark)) todo-marks) |
1544 |
|
(if (numberp (cdr ranges)) (setq ranges (list ranges))) |
1545 |
|
(nnmaildir--nlist-iterate nlist ranges |
1546 |
|
(cond ((eq 'del (cadr action)) del-action) |
1547 |
|
((eq 'add (cadr action)) add-action) |
1548 |
|
(t set-action)))) |
1549 |
|
actions) |
1550 |
|
nil))) |
1551 |
|
|
1552 |
|
(defun nnmaildir-close-group (gname &optional server) |
1553 |
|
(let ((group (nnmaildir--prepare server gname)) |
1554 |
|
pgname ls dir msgdir files flist dirs) |
1555 |
|
(if (null group) |
1556 |
|
(progn |
1557 |
|
(setf (nnmaildir--srv-error nnmaildir--cur-server) |
1558 |
|
(concat "No such group: " gname)) |
1559 |
|
nil) |
1560 |
|
(setq pgname (nnmaildir--pgname nnmaildir--cur-server gname) |
1561 |
|
ls (nnmaildir--group-ls nnmaildir--cur-server pgname) |
1562 |
|
dir (nnmaildir--srv-dir nnmaildir--cur-server) |
1563 |
|
dir (nnmaildir--srvgrp-dir dir gname) |
1564 |
|
msgdir (if (nnmaildir--param pgname 'read-only) |
1565 |
|
(nnmaildir--new dir) (nnmaildir--cur dir)) |
1566 |
|
dir (nnmaildir--nndir dir) |
1567 |
|
dirs (cons (nnmaildir--nov-dir dir) |
1568 |
|
(funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]" |
1569 |
|
'nosort)) |
1570 |
|
dirs (mapcar |
1571 |
|
(lambda (dir) |
1572 |
|
(cons dir (funcall ls dir nil "\\`[^.]" 'nosort))) |
1573 |
|
dirs) |
1574 |
|
files (funcall ls msgdir nil "\\`[^.]" 'nosort) |
1575 |
|
flist (nnmaildir--up2-1 (length files)) |
1576 |
|
flist (make-vector flist 0)) |
1577 |
|
(save-match-data |
1578 |
|
(mapcar |
1579 |
|
(lambda (file) |
1580 |
|
(string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file) |
1581 |
|
(intern (match-string 1 file) flist)) |
1582 |
|
files)) |
1583 |
|
(mapcar |
1584 |
|
(lambda (dir) |
1585 |
|
(setq files (cdr dir) |
1586 |
|
dir (file-name-as-directory (car dir))) |
1587 |
|
(mapcar |
1588 |
|
(lambda (file) |
1589 |
|
(unless (or (intern-soft file flist) (string= file ":")) |
1590 |
|
(setq file (concat dir file)) |
1591 |
|
(delete-file file))) |
1592 |
|
files)) |
1593 |
|
dirs) |
1594 |
|
t))) |
1595 |
|
|
1596 |
|
(defun nnmaildir-close-server (&optional server) |
1597 |
|
(let (flist ls dirs dir files file x) |
1598 |
|
(nnmaildir--prepare server nil) |
1599 |
|
(when nnmaildir--cur-server |
1600 |
|
(setq server nnmaildir--cur-server |
1601 |
|
nnmaildir--cur-server nil) |
1602 |
|
(unintern (nnmaildir--srv-address server) nnmaildir--servers))) |
1603 |
|
t) |
1604 |
|
|
1605 |
|
(defun nnmaildir-request-close () |
1606 |
|
(let (servers buffer) |
1607 |
|
(mapatoms (lambda (server) |
1608 |
|
(setq servers (cons (symbol-name server) servers))) |
1609 |
|
nnmaildir--servers) |
1610 |
|
(mapcar 'nnmaildir-close-server servers) |
1611 |
|
(setq buffer (get-buffer " *nnmaildir work*")) |
1612 |
|
(if buffer (kill-buffer buffer)) |
1613 |
|
(setq buffer (get-buffer " *nnmaildir nov*")) |
1614 |
|
(if buffer (kill-buffer buffer)) |
1615 |
|
(setq buffer (get-buffer " *nnmaildir move*")) |
1616 |
|
(if buffer (kill-buffer buffer))) |
1617 |
|
t) |
1618 |
|
|
1619 |
|
(provide 'nnmaildir) |
1620 |
|
|
1621 |
|
;; Local Variables: |
1622 |
|
;; indent-tabs-mode: t |
1623 |
|
;; fill-column: 77 |
1624 |
|
;; End: |
1625 |
|
|
1626 |
|
;;; arch-tag: 0c4e44cd-dfde-4040-888e-5597ec771849 |
1627 |
|
;;; nnmaildir.el ends here |