Mercurial > emacs
annotate lisp/gnus/nnmh.el @ 31697:5732e757b20f
(menu_bar_items, tool_bar_items)
(current_active_maps): Remove redundant get_local_map call.
author | Dave Love <fx@gnu.org> |
---|---|
date | Mon, 18 Sep 2000 18:45:01 +0000 |
parents | 15fc6acbae7a |
children | 9968f55ad26e |
rev | line source |
---|---|
17493 | 1 ;;; nnmh.el --- mhspool access for Gnus |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
2 ;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc. |
17493 | 3 |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
17493 | 5 ;; Masanobu UMEDA <umerin@flab.flab.fujitsu.junet> |
6 ;; Keywords: news, mail | |
7 | |
8 ;; This file is part of GNU Emacs. | |
9 | |
10 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
11 ;; it under the terms of the GNU General Public License as published by | |
12 ;; the Free Software Foundation; either version 2, or (at your option) | |
13 ;; any later version. | |
14 | |
15 ;; GNU Emacs is distributed in the hope that it will be useful, | |
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 ;; GNU General Public License for more details. | |
19 | |
20 ;; You should have received a copy of the GNU General Public License | |
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
23 ;; Boston, MA 02111-1307, USA. | |
24 | |
25 ;;; Commentary: | |
26 | |
27 ;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>. | |
28 ;; For an overview of what the interface functions do, please see the | |
29 ;; Gnus sources. | |
30 | |
31 ;;; Code: | |
32 | |
33 (require 'nnheader) | |
34 (require 'nnmail) | |
35 (require 'gnus-start) | |
36 (require 'nnoo) | |
19494
4280cff25537
Require cl only at compile time.
Richard M. Stallman <rms@gnu.org>
parents:
17493
diff
changeset
|
37 (eval-when-compile (require 'cl)) |
17493 | 38 |
39 (nnoo-declare nnmh) | |
40 | |
41 (defvoo nnmh-directory message-directory | |
42 "*Mail spool directory.") | |
43 | |
44 (defvoo nnmh-get-new-mail t | |
45 "*If non-nil, nnmh will check the incoming mail file and split the mail.") | |
46 | |
47 (defvoo nnmh-prepare-save-mail-hook nil | |
48 "*Hook run narrowed to an article before saving.") | |
49 | |
50 (defvoo nnmh-be-safe nil | |
51 "*If non-nil, nnmh will check all articles to make sure whether they are new or not.") | |
52 | |
53 | |
54 | |
55 (defconst nnmh-version "nnmh 1.0" | |
56 "nnmh version.") | |
57 | |
58 (defvoo nnmh-current-directory nil | |
59 "Current news group directory.") | |
60 | |
61 (defvoo nnmh-status-string "") | |
62 (defvoo nnmh-group-alist nil) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
63 (defvoo nnmh-allow-delete-final nil) |
17493 | 64 |
65 | |
66 | |
67 ;;; Interface functions. | |
68 | |
69 (nnoo-define-basics nnmh) | |
70 | |
71 (deffoo nnmh-retrieve-headers (articles &optional newsgroup server fetch-old) | |
72 (save-excursion | |
73 (set-buffer nntp-server-buffer) | |
74 (erase-buffer) | |
75 (let* ((file nil) | |
76 (number (length articles)) | |
77 (large (and (numberp nnmail-large-newsgroup) | |
78 (> number nnmail-large-newsgroup))) | |
79 (count 0) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
80 (file-name-coding-system 'binary) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
81 (pathname-coding-system 'binary) |
17493 | 82 beg article) |
83 (nnmh-possibly-change-directory newsgroup server) | |
84 ;; We don't support fetching by Message-ID. | |
85 (if (stringp (car articles)) | |
86 'headers | |
87 (while articles | |
88 (when (and (file-exists-p | |
89 (setq file (concat (file-name-as-directory | |
90 nnmh-current-directory) | |
91 (int-to-string | |
92 (setq article (pop articles)))))) | |
93 (not (file-directory-p file))) | |
94 (insert (format "221 %d Article retrieved.\n" article)) | |
95 (setq beg (point)) | |
96 (nnheader-insert-head file) | |
97 (goto-char beg) | |
98 (if (search-forward "\n\n" nil t) | |
99 (forward-char -1) | |
100 (goto-char (point-max)) | |
101 (insert "\n\n")) | |
102 (insert ".\n") | |
103 (delete-region (point) (point-max))) | |
104 (setq count (1+ count)) | |
105 | |
106 (and large | |
107 (zerop (% count 20)) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
108 (nnheader-message 5 "nnmh: Receiving headers... %d%%" |
17493 | 109 (/ (* count 100) number)))) |
110 | |
111 (when large | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
112 (nnheader-message 5 "nnmh: Receiving headers...done")) |
17493 | 113 |
114 (nnheader-fold-continuation-lines) | |
115 'headers)))) | |
116 | |
117 (deffoo nnmh-open-server (server &optional defs) | |
118 (nnoo-change-server 'nnmh server defs) | |
119 (when (not (file-exists-p nnmh-directory)) | |
120 (condition-case () | |
121 (make-directory nnmh-directory t) | |
122 (error t))) | |
123 (cond | |
124 ((not (file-exists-p nnmh-directory)) | |
125 (nnmh-close-server) | |
126 (nnheader-report 'nnmh "Couldn't create directory: %s" nnmh-directory)) | |
127 ((not (file-directory-p (file-truename nnmh-directory))) | |
128 (nnmh-close-server) | |
129 (nnheader-report 'nnmh "Not a directory: %s" nnmh-directory)) | |
130 (t | |
131 (nnheader-report 'nnmh "Opened server %s using directory %s" | |
132 server nnmh-directory) | |
133 t))) | |
134 | |
135 (deffoo nnmh-request-article (id &optional newsgroup server buffer) | |
136 (nnmh-possibly-change-directory newsgroup server) | |
137 (let ((file (if (stringp id) | |
138 nil | |
139 (concat nnmh-current-directory (int-to-string id)))) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
140 (pathname-coding-system 'binary) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
141 (file-name-coding-system 'binary) |
17493 | 142 (nntp-server-buffer (or buffer nntp-server-buffer))) |
143 (and (stringp file) | |
144 (file-exists-p file) | |
145 (not (file-directory-p file)) | |
146 (save-excursion (nnmail-find-file file)) | |
147 (string-to-int (file-name-nondirectory file))))) | |
148 | |
149 (deffoo nnmh-request-group (group &optional server dont-check) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
150 (nnheader-init-server-buffer) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
151 (nnmh-possibly-change-directory group server) |
17493 | 152 (let ((pathname (nnmail-group-pathname group nnmh-directory)) |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
153 (pathname-coding-system 'binary) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
154 (file-name-coding-system 'binary) |
17493 | 155 dir) |
156 (cond | |
157 ((not (file-directory-p pathname)) | |
158 (nnheader-report | |
159 'nnmh "Can't select group (no such directory): %s" group)) | |
160 (t | |
161 (setq nnmh-current-directory pathname) | |
162 (and nnmh-get-new-mail | |
163 nnmh-be-safe | |
164 (nnmh-update-gnus-unreads group)) | |
165 (cond | |
166 (dont-check | |
167 (nnheader-report 'nnmh "Selected group %s" group) | |
168 t) | |
169 (t | |
170 ;; Re-scan the directory if it's on a foreign system. | |
171 (nnheader-re-read-dir pathname) | |
172 (setq dir | |
173 (sort | |
174 (mapcar (lambda (name) (string-to-int name)) | |
175 (directory-files pathname nil "^[0-9]+$" t)) | |
176 '<)) | |
177 (cond | |
178 (dir | |
179 (nnheader-report 'nnmh "Selected group %s" group) | |
180 (nnheader-insert | |
181 "211 %d %d %d %s\n" (length dir) (car dir) | |
182 (progn (while (cdr dir) (setq dir (cdr dir))) (car dir)) | |
183 group)) | |
184 (t | |
185 (nnheader-report 'nnmh "Empty group %s" group) | |
186 (nnheader-insert (format "211 0 1 0 %s\n" group)))))))))) | |
187 | |
188 (deffoo nnmh-request-scan (&optional group server) | |
189 (nnmail-get-new-mail 'nnmh nil nnmh-directory group)) | |
190 | |
191 (deffoo nnmh-request-list (&optional server dir) | |
192 (nnheader-insert "") | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
193 (nnmh-possibly-change-directory nil server) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
194 (let* ((pathname-coding-system 'binary) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
195 (file-name-coding-system 'binary) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
196 (nnmh-toplev |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
197 (file-truename (or dir (file-name-as-directory nnmh-directory))))) |
17493 | 198 (nnmh-request-list-1 nnmh-toplev)) |
199 (setq nnmh-group-alist (nnmail-get-active)) | |
200 t) | |
201 | |
202 (defvar nnmh-toplev) | |
203 (defun nnmh-request-list-1 (dir) | |
204 (setq dir (expand-file-name dir)) | |
205 ;; Recurse down all directories. | |
206 (let ((dirs (and (file-readable-p dir) | |
207 (> (nth 1 (file-attributes (file-chase-links dir))) 2) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
208 (nnheader-directory-files dir t nil t))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
209 rdir) |
17493 | 210 ;; Recurse down directories. |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
211 (while (setq rdir (pop dirs)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
212 (when (and (file-directory-p rdir) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
213 (file-readable-p rdir) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
214 (not (equal (file-truename rdir) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
215 (file-truename dir)))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
216 (nnmh-request-list-1 rdir)))) |
17493 | 217 ;; For each directory, generate an active file line. |
218 (unless (string= (expand-file-name nnmh-toplev) dir) | |
219 (let ((files (mapcar | |
220 (lambda (name) (string-to-int name)) | |
221 (directory-files dir nil "^[0-9]+$" t)))) | |
222 (when files | |
223 (save-excursion | |
224 (set-buffer nntp-server-buffer) | |
225 (goto-char (point-max)) | |
226 (insert | |
227 (format | |
228 "%s %d %d y\n" | |
229 (progn | |
230 (string-match | |
231 (regexp-quote | |
232 (file-truename (file-name-as-directory | |
233 (expand-file-name nnmh-toplev)))) | |
234 dir) | |
235 (nnheader-replace-chars-in-string | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
236 (gnus-decode-coding-string (substring dir (match-end 0)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
237 nnmail-pathname-coding-system) |
19602
549f21ee4bf0
(nnmh-request-list, nnmh-active-number): Protect from
Kenichi Handa <handa@m17n.org>
parents:
19494
diff
changeset
|
238 ?/ ?.)) |
17493 | 239 (apply 'max files) |
240 (apply 'min files))))))) | |
241 t) | |
242 | |
243 (deffoo nnmh-request-newgroups (date &optional server) | |
244 (nnmh-request-list server)) | |
245 | |
246 (deffoo nnmh-request-expire-articles (articles newsgroup | |
247 &optional server force) | |
248 (nnmh-possibly-change-directory newsgroup server) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
249 (let* ((is-old t) |
17493 | 250 article rest mod-time) |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
251 (nnheader-init-server-buffer) |
17493 | 252 |
253 (while (and articles is-old) | |
254 (setq article (concat nnmh-current-directory | |
255 (int-to-string (car articles)))) | |
256 (when (setq mod-time (nth 5 (file-attributes article))) | |
257 (if (and (nnmh-deletable-article-p newsgroup (car articles)) | |
258 (setq is-old | |
259 (nnmail-expired-article-p newsgroup mod-time force))) | |
260 (progn | |
261 (nnheader-message 5 "Deleting article %s in %s..." | |
262 article newsgroup) | |
263 (condition-case () | |
264 (funcall nnmail-delete-file-function article) | |
265 (file-error | |
266 (nnheader-message 1 "Couldn't delete article %s in %s" | |
267 article newsgroup) | |
268 (push (car articles) rest)))) | |
269 (push (car articles) rest))) | |
270 (setq articles (cdr articles))) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
271 (nnheader-message 5 "") |
17493 | 272 (nconc rest articles))) |
273 | |
274 (deffoo nnmh-close-group (group &optional server) | |
275 t) | |
276 | |
277 (deffoo nnmh-request-move-article | |
278 (article group server accept-form &optional last) | |
279 (let ((buf (get-buffer-create " *nnmh move*")) | |
280 result) | |
281 (and | |
282 (nnmh-deletable-article-p group article) | |
283 (nnmh-request-article article group server) | |
284 (save-excursion | |
285 (set-buffer buf) | |
286 (erase-buffer) | |
287 (insert-buffer-substring nntp-server-buffer) | |
288 (setq result (eval accept-form)) | |
289 (kill-buffer (current-buffer)) | |
290 result) | |
291 (progn | |
292 (nnmh-possibly-change-directory group server) | |
293 (condition-case () | |
294 (funcall nnmail-delete-file-function | |
295 (concat nnmh-current-directory (int-to-string article))) | |
296 (file-error nil)))) | |
297 result)) | |
298 | |
299 (deffoo nnmh-request-accept-article (group &optional server last noinsert) | |
300 (nnmh-possibly-change-directory group server) | |
301 (nnmail-check-syntax) | |
302 (when nnmail-cache-accepted-message-ids | |
303 (nnmail-cache-insert (nnmail-fetch-field "message-id"))) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
304 (nnheader-init-server-buffer) |
17493 | 305 (prog1 |
306 (if (stringp group) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
307 (if noinsert |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
308 (nnmh-active-number group) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
309 (car (nnmh-save-mail |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
310 (list (cons group (nnmh-active-number group))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
311 noinsert))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
312 (let ((res (nnmail-article-group 'nnmh-active-number))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
313 (if (and (null res) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
314 (yes-or-no-p "Moved to `junk' group; delete article? ")) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
315 'junk |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
316 (car (nnmh-save-mail res noinsert))))) |
17493 | 317 (when (and last nnmail-cache-accepted-message-ids) |
318 (nnmail-cache-close)))) | |
319 | |
320 (deffoo nnmh-request-replace-article (article group buffer) | |
321 (nnmh-possibly-change-directory group) | |
322 (save-excursion | |
323 (set-buffer buffer) | |
324 (nnmh-possibly-create-directory group) | |
325 (ignore-errors | |
326 (nnmail-write-region | |
327 (point-min) (point-max) | |
328 (concat nnmh-current-directory (int-to-string article)) | |
329 nil (if (nnheader-be-verbose 5) nil 'nomesg)) | |
330 t))) | |
331 | |
332 (deffoo nnmh-request-create-group (group &optional server args) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
333 (nnheader-init-server-buffer) |
17493 | 334 (unless (assoc group nnmh-group-alist) |
335 (let (active) | |
336 (push (list group (setq active (cons 1 0))) | |
337 nnmh-group-alist) | |
338 (nnmh-possibly-create-directory group) | |
339 (nnmh-possibly-change-directory group server) | |
340 (let ((articles (mapcar | |
341 (lambda (file) | |
342 (string-to-int file)) | |
343 (directory-files | |
344 nnmh-current-directory nil "^[0-9]+$")))) | |
345 (when articles | |
346 (setcar active (apply 'min articles)) | |
347 (setcdr active (apply 'max articles)))))) | |
348 t) | |
349 | |
350 (deffoo nnmh-request-delete-group (group &optional force server) | |
351 (nnmh-possibly-change-directory group server) | |
352 ;; Delete all articles in GROUP. | |
353 (if (not force) | |
354 () ; Don't delete the articles. | |
355 (let ((articles (directory-files nnmh-current-directory t "^[0-9]+$"))) | |
356 (while articles | |
357 (when (file-writable-p (car articles)) | |
358 (nnheader-message 5 "Deleting article %s in %s..." | |
359 (car articles) group) | |
360 (funcall nnmail-delete-file-function (car articles))) | |
361 (setq articles (cdr articles)))) | |
362 ;; Try to delete the directory itself. | |
363 (ignore-errors | |
364 (delete-directory nnmh-current-directory))) | |
365 ;; Remove the group from all structures. | |
366 (setq nnmh-group-alist | |
367 (delq (assoc group nnmh-group-alist) nnmh-group-alist) | |
368 nnmh-current-directory nil) | |
369 t) | |
370 | |
371 (deffoo nnmh-request-rename-group (group new-name &optional server) | |
372 (nnmh-possibly-change-directory group server) | |
373 (let ((new-dir (nnmail-group-pathname new-name nnmh-directory)) | |
374 (old-dir (nnmail-group-pathname group nnmh-directory))) | |
375 (when (ignore-errors | |
376 (make-directory new-dir t) | |
377 t) | |
378 ;; We move the articles file by file instead of renaming | |
379 ;; the directory -- there may be subgroups in this group. | |
380 ;; One might be more clever, I guess. | |
381 (let ((files (nnheader-article-to-file-alist old-dir))) | |
382 (while files | |
383 (rename-file | |
384 (concat old-dir (cdar files)) | |
385 (concat new-dir (cdar files))) | |
386 (pop files))) | |
387 (when (<= (length (directory-files old-dir)) 2) | |
388 (ignore-errors | |
389 (delete-directory old-dir))) | |
390 ;; That went ok, so we change the internal structures. | |
391 (let ((entry (assoc group nnmh-group-alist))) | |
392 (when entry | |
393 (setcar entry new-name)) | |
394 (setq nnmh-current-directory nil) | |
395 t)))) | |
396 | |
397 (nnoo-define-skeleton nnmh) | |
398 | |
399 | |
400 ;;; Internal functions. | |
401 | |
402 (defun nnmh-possibly-change-directory (newsgroup &optional server) | |
403 (when (and server | |
404 (not (nnmh-server-opened server))) | |
405 (nnmh-open-server server)) | |
406 (when newsgroup | |
19602
549f21ee4bf0
(nnmh-request-list, nnmh-active-number): Protect from
Kenichi Handa <handa@m17n.org>
parents:
19494
diff
changeset
|
407 (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory)) |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
408 (file-name-coding-system 'binary) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
409 (pathname-coding-system 'binary)) |
17493 | 410 (if (file-directory-p pathname) |
411 (setq nnmh-current-directory pathname) | |
412 (error "No such newsgroup: %s" newsgroup))))) | |
413 | |
414 (defun nnmh-possibly-create-directory (group) | |
415 (let (dir dirs) | |
416 (setq dir (nnmail-group-pathname group nnmh-directory)) | |
417 (while (not (file-directory-p dir)) | |
418 (push dir dirs) | |
419 (setq dir (file-name-directory (directory-file-name dir)))) | |
420 (while dirs | |
421 (when (make-directory (directory-file-name (car dirs))) | |
422 (error "Could not create directory %s" (car dirs))) | |
423 (nnheader-message 5 "Creating mail directory %s" (car dirs)) | |
424 (setq dirs (cdr dirs))))) | |
425 | |
426 (defun nnmh-save-mail (group-art &optional noinsert) | |
427 "Called narrowed to an article." | |
428 (unless noinsert | |
429 (nnmail-insert-lines) | |
430 (nnmail-insert-xref group-art)) | |
431 (run-hooks 'nnmail-prepare-save-mail-hook) | |
432 (run-hooks 'nnmh-prepare-save-mail-hook) | |
433 (goto-char (point-min)) | |
434 (while (looking-at "From ") | |
435 (replace-match "X-From-Line: ") | |
436 (forward-line 1)) | |
437 ;; We save the article in all the newsgroups it belongs in. | |
438 (let ((ga group-art) | |
439 first) | |
440 (while ga | |
441 (nnmh-possibly-create-directory (caar ga)) | |
442 (let ((file (concat (nnmail-group-pathname | |
443 (caar ga) nnmh-directory) | |
444 (int-to-string (cdar ga))))) | |
445 (if first | |
446 ;; It was already saved, so we just make a hard link. | |
447 (funcall nnmail-crosspost-link-function first file t) | |
448 ;; Save the article. | |
449 (nnmail-write-region (point-min) (point-max) file nil nil) | |
450 (setq first file))) | |
451 (setq ga (cdr ga)))) | |
452 group-art) | |
453 | |
454 (defun nnmh-active-number (group) | |
455 "Compute the next article number in GROUP." | |
456 (let ((active (cadr (assoc group nnmh-group-alist))) | |
19602
549f21ee4bf0
(nnmh-request-list, nnmh-active-number): Protect from
Kenichi Handa <handa@m17n.org>
parents:
19494
diff
changeset
|
457 (dir (nnmail-group-pathname group nnmh-directory)) |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
458 (file-name-coding-system 'binary) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
459 (pathname-coding-system 'binary)) |
17493 | 460 (unless active |
461 ;; The group wasn't known to nnmh, so we just create an active | |
462 ;; entry for it. | |
463 (setq active (cons 1 0)) | |
464 (push (list group active) nnmh-group-alist) | |
465 (unless (file-exists-p dir) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
466 (gnus-make-directory dir)) |
17493 | 467 ;; Find the highest number in the group. |
468 (let ((files (sort | |
469 (mapcar | |
470 (lambda (f) | |
471 (string-to-int f)) | |
472 (directory-files dir nil "^[0-9]+$")) | |
473 '>))) | |
474 (when files | |
475 (setcdr active (car files))))) | |
476 (setcdr active (1+ (cdr active))) | |
477 (while (file-exists-p | |
478 (concat (nnmail-group-pathname group nnmh-directory) | |
479 (int-to-string (cdr active)))) | |
480 (setcdr active (1+ (cdr active)))) | |
481 (cdr active))) | |
482 | |
483 (defun nnmh-update-gnus-unreads (group) | |
484 ;; Go through the .nnmh-articles file and compare with the actual | |
485 ;; articles in this folder. The articles that are "new" will be | |
486 ;; marked as unread by Gnus. | |
487 (let* ((dir nnmh-current-directory) | |
488 (files (sort (mapcar (function (lambda (name) (string-to-int name))) | |
489 (directory-files nnmh-current-directory | |
490 nil "^[0-9]+$" t)) | |
491 '<)) | |
492 (nnmh-file (concat dir ".nnmh-articles")) | |
493 new articles) | |
494 ;; Load the .nnmh-articles file. | |
495 (when (file-exists-p nnmh-file) | |
496 (setq articles | |
497 (let (nnmh-newsgroup-articles) | |
498 (ignore-errors (load nnmh-file nil t t)) | |
499 nnmh-newsgroup-articles))) | |
500 ;; Add all new articles to the `new' list. | |
501 (let ((art files)) | |
502 (while art | |
503 (unless (assq (car art) articles) | |
504 (push (car art) new)) | |
505 (setq art (cdr art)))) | |
506 ;; Remove all deleted articles. | |
507 (let ((art articles)) | |
508 (while art | |
509 (unless (memq (caar art) files) | |
510 (setq articles (delq (car art) articles))) | |
511 (setq art (cdr art)))) | |
512 ;; Check whether the articles really are the ones that Gnus thinks | |
513 ;; they are by looking at the time-stamps. | |
514 (let ((arts articles) | |
515 art) | |
516 (while (setq art (pop arts)) | |
517 (when (not (equal | |
518 (nth 5 (file-attributes | |
519 (concat dir (int-to-string (car art))))) | |
520 (cdr art))) | |
521 (setq articles (delq art articles)) | |
522 (push (car art) new)))) | |
523 ;; Go through all the new articles and add them, and their | |
524 ;; time-stamps, to the list. | |
525 (setq articles | |
526 (nconc articles | |
527 (mapcar | |
528 (lambda (art) | |
529 (cons art | |
530 (nth 5 (file-attributes | |
531 (concat dir (int-to-string art)))))) | |
532 new))) | |
533 ;; Make Gnus mark all new articles as unread. | |
534 (when new | |
535 (gnus-make-articles-unread | |
536 (gnus-group-prefixed-name group (list 'nnmh "")) | |
537 (setq new (sort new '<)))) | |
538 ;; Sort the article list with highest numbers first. | |
539 (setq articles (sort articles (lambda (art1 art2) | |
540 (> (car art1) (car art2))))) | |
541 ;; Finally write this list back to the .nnmh-articles file. | |
542 (nnheader-temp-write nnmh-file | |
543 (insert ";; Gnus article active file for " group "\n\n") | |
544 (insert "(setq nnmh-newsgroup-articles '") | |
545 (gnus-prin1 articles) | |
546 (insert ")\n")))) | |
547 | |
548 (defun nnmh-deletable-article-p (group article) | |
549 "Say whether ARTICLE in GROUP can be deleted." | |
550 (let ((path (concat nnmh-current-directory (int-to-string article)))) | |
551 ;; Writable. | |
552 (and (file-writable-p path) | |
24357
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
553 (or |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
554 ;; We can never delete the last article in the group. |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
555 (not (eq (cdr (nth 1 (assoc group nnmh-group-alist))) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
556 article)) |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
557 ;; Well, we can. |
15fc6acbae7a
Upgrading to Gnus 5.7; see ChangeLog
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
19995
diff
changeset
|
558 nnmh-allow-delete-final)))) |
17493 | 559 |
560 (provide 'nnmh) | |
561 | |
562 ;;; nnmh.el ends here |