Mercurial > emacs
annotate lisp/nnmh.el @ 20047:735f0cdfc5b9
(winner-change-fun): Don't use pushnew.
author | Karl Heuer <kwzh@gnu.org> |
---|---|
date | Wed, 15 Oct 1997 22:41:09 +0000 |
parents | 8d8bf85d356a |
children |
rev | line source |
---|---|
13401 | 1 ;;; nnmh.el --- mhspool access for Gnus |
15511 | 2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc. |
13401 | 3 |
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> | |
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 | |
14169 | 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. | |
13401 | 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) | |
15511 | 36 (require 'nnoo) |
37 (eval-and-compile (require 'cl)) | |
13401 | 38 |
15511 | 39 (nnoo-declare nnmh) |
40 | |
41 (defvoo nnmh-directory message-directory | |
13401 | 42 "*Mail spool directory.") |
43 | |
15511 | 44 (defvoo nnmh-get-new-mail t |
13401 | 45 "*If non-nil, nnmh will check the incoming mail file and split the mail.") |
46 | |
15511 | 47 (defvoo nnmh-prepare-save-mail-hook nil |
13401 | 48 "*Hook run narrowed to an article before saving.") |
49 | |
15511 | 50 (defvoo nnmh-be-safe nil |
13401 | 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 | |
15511 | 58 (defvoo nnmh-current-directory nil |
13401 | 59 "Current news group directory.") |
60 | |
15511 | 61 (defvoo nnmh-status-string "") |
62 (defvoo nnmh-group-alist nil) | |
13401 | 63 |
64 | |
65 | |
66 ;;; Interface functions. | |
67 | |
15511 | 68 (nnoo-define-basics nnmh) |
69 | |
70 (deffoo nnmh-retrieve-headers (articles &optional newsgroup server fetch-old) | |
13401 | 71 (save-excursion |
72 (set-buffer nntp-server-buffer) | |
73 (erase-buffer) | |
74 (let* ((file nil) | |
15511 | 75 (number (length articles)) |
13401 | 76 (large (and (numberp nnmail-large-newsgroup) |
77 (> number nnmail-large-newsgroup))) | |
78 (count 0) | |
79 beg article) | |
15511 | 80 (nnmh-possibly-change-directory newsgroup server) |
81 ;; We don't support fetching by Message-ID. | |
82 (if (stringp (car articles)) | |
13401 | 83 'headers |
15511 | 84 (while articles |
85 (when (and (file-exists-p | |
86 (setq file (concat (file-name-as-directory | |
87 nnmh-current-directory) | |
88 (int-to-string | |
89 (setq article (pop articles)))))) | |
90 (not (file-directory-p file))) | |
91 (insert (format "221 %d Article retrieved.\n" article)) | |
92 (setq beg (point)) | |
93 (nnheader-insert-head file) | |
94 (goto-char beg) | |
95 (if (search-forward "\n\n" nil t) | |
96 (forward-char -1) | |
97 (goto-char (point-max)) | |
98 (insert "\n\n")) | |
99 (insert ".\n") | |
100 (delete-region (point) (point-max))) | |
13401 | 101 (setq count (1+ count)) |
102 | |
103 (and large | |
104 (zerop (% count 20)) | |
105 (message "nnmh: Receiving headers... %d%%" | |
106 (/ (* count 100) number)))) | |
107 | |
108 (and large (message "nnmh: Receiving headers...done")) | |
109 | |
15511 | 110 (nnheader-fold-continuation-lines) |
13401 | 111 'headers)))) |
112 | |
15511 | 113 (deffoo nnmh-open-server (server &optional defs) |
114 (nnoo-change-server 'nnmh server defs) | |
115 (when (not (file-exists-p nnmh-directory)) | |
116 (condition-case () | |
117 (make-directory nnmh-directory t) | |
118 (error t))) | |
119 (cond | |
120 ((not (file-exists-p nnmh-directory)) | |
121 (nnmh-close-server) | |
122 (nnheader-report 'nnmh "Couldn't create directory: %s" nnmh-directory)) | |
123 ((not (file-directory-p (file-truename nnmh-directory))) | |
124 (nnmh-close-server) | |
125 (nnheader-report 'nnmh "Not a directory: %s" nnmh-directory)) | |
126 (t | |
127 (nnheader-report 'nnmh "Opened server %s using directory %s" | |
128 server nnmh-directory) | |
129 t))) | |
13401 | 130 |
15511 | 131 (deffoo nnmh-request-article (id &optional newsgroup server buffer) |
132 (nnmh-possibly-change-directory newsgroup server) | |
13401 | 133 (let ((file (if (stringp id) |
134 nil | |
135 (concat nnmh-current-directory (int-to-string id)))) | |
136 (nntp-server-buffer (or buffer nntp-server-buffer))) | |
137 (and (stringp file) | |
138 (file-exists-p file) | |
139 (not (file-directory-p file)) | |
15511 | 140 (save-excursion (nnmail-find-file file)) |
141 (string-to-int (file-name-nondirectory file))))) | |
13401 | 142 |
15511 | 143 (deffoo nnmh-request-group (group &optional server dont-check) |
144 (let ((pathname (nnmail-group-pathname group nnmh-directory)) | |
13401 | 145 dir) |
15511 | 146 (cond |
147 ((not (file-directory-p pathname)) | |
148 (nnheader-report | |
149 'nnmh "Can't select group (no such directory): %s" group)) | |
150 (t | |
151 (setq nnmh-current-directory pathname) | |
152 (and nnmh-get-new-mail | |
153 nnmh-be-safe | |
154 (nnmh-update-gnus-unreads group)) | |
155 (cond | |
156 (dont-check | |
157 (nnheader-report 'nnmh "Selected group %s" group) | |
158 t) | |
159 (t | |
15559
8d8bf85d356a
Synched with Gnus 5.2.31.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
15511
diff
changeset
|
160 ;; Re-scan the directory if it's on a foreign system. |
8d8bf85d356a
Synched with Gnus 5.2.31.
Lars Magne Ingebrigtsen <larsi@gnus.org>
parents:
15511
diff
changeset
|
161 (nnheader-re-read-dir pathname) |
15511 | 162 (setq dir |
163 (sort | |
164 (mapcar (lambda (name) (string-to-int name)) | |
165 (directory-files pathname nil "^[0-9]+$" t)) | |
166 '<)) | |
167 (cond | |
168 (dir | |
169 (nnheader-report 'nnmh "Selected group %s" group) | |
170 (nnheader-insert | |
171 "211 %d %d %d %s\n" (length dir) (car dir) | |
172 (progn (while (cdr dir) (setq dir (cdr dir))) (car dir)) | |
173 group)) | |
174 (t | |
175 (nnheader-report 'nnmh "Empty group %s" group) | |
176 (nnheader-insert (format "211 0 1 0 %s\n" group)))))))))) | |
13401 | 177 |
15511 | 178 (deffoo nnmh-request-scan (&optional group server) |
179 (nnmail-get-new-mail 'nnmh nil nnmh-directory group)) | |
180 | |
181 (deffoo nnmh-request-list (&optional server dir) | |
182 (nnheader-insert "") | |
183 (let ((nnmh-toplev | |
184 (or dir (file-truename (file-name-as-directory nnmh-directory))))) | |
185 (nnmh-request-list-1 nnmh-toplev)) | |
186 (setq nnmh-group-alist (nnmail-get-active)) | |
187 t) | |
188 | |
189 (defvar nnmh-toplev) | |
190 (defun nnmh-request-list-1 (dir) | |
13401 | 191 (setq dir (expand-file-name dir)) |
192 ;; Recurse down all directories. | |
193 (let ((dirs (and (file-readable-p dir) | |
194 (> (nth 1 (file-attributes (file-chase-links dir))) 2) | |
15511 | 195 (directory-files dir t nil t))) |
196 dir) | |
197 ;; Recurse down directories. | |
198 (while (setq dir (pop dirs)) | |
199 (when (and (not (member (file-name-nondirectory dir) '("." ".."))) | |
200 (file-directory-p dir) | |
201 (file-readable-p dir)) | |
202 (nnmh-request-list-1 dir)))) | |
13401 | 203 ;; For each directory, generate an active file line. |
15511 | 204 (unless (string= (expand-file-name nnmh-toplev) dir) |
205 (let ((files (mapcar | |
206 (lambda (name) (string-to-int name)) | |
207 (directory-files dir nil "^[0-9]+$" t)))) | |
208 (when files | |
209 (save-excursion | |
210 (set-buffer nntp-server-buffer) | |
211 (goto-char (point-max)) | |
212 (insert | |
213 (format | |
214 "%s %d %d y\n" | |
215 (progn | |
216 (string-match | |
217 (regexp-quote | |
218 (file-truename (file-name-as-directory | |
219 (expand-file-name nnmh-toplev)))) dir) | |
220 (nnheader-replace-chars-in-string | |
221 (substring dir (match-end 0)) ?/ ?.)) | |
222 (apply 'max files) | |
223 (apply 'min files))))))) | |
13401 | 224 t) |
225 | |
15511 | 226 (deffoo nnmh-request-newgroups (date &optional server) |
13401 | 227 (nnmh-request-list server)) |
228 | |
15511 | 229 (deffoo nnmh-request-expire-articles (articles newsgroup &optional server force) |
230 (nnmh-possibly-change-directory newsgroup server) | |
231 (let* ((active-articles | |
13401 | 232 (mapcar |
233 (function | |
234 (lambda (name) | |
235 (string-to-int name))) | |
236 (directory-files nnmh-current-directory nil "^[0-9]+$" t))) | |
237 (is-old t) | |
238 article rest mod-time) | |
239 (nnmail-activate 'nnmh) | |
240 | |
241 (while (and articles is-old) | |
242 (setq article (concat nnmh-current-directory | |
243 (int-to-string (car articles)))) | |
244 (if (setq mod-time (nth 5 (file-attributes article))) | |
15511 | 245 (if (and (nnmh-deletable-article-p newsgroup (car articles)) |
246 (setq is-old | |
247 (nnmail-expired-article-p newsgroup mod-time force))) | |
13401 | 248 (progn |
15511 | 249 (nnheader-message 5 "Deleting article %s in %s..." |
250 article newsgroup) | |
13401 | 251 (condition-case () |
15511 | 252 (funcall nnmail-delete-file-function article) |
13401 | 253 (file-error |
15511 | 254 (nnheader-message 1 "Couldn't delete article %s in %s" |
255 article newsgroup) | |
13401 | 256 (setq rest (cons (car articles) rest))))) |
257 (setq rest (cons (car articles) rest)))) | |
258 (setq articles (cdr articles))) | |
259 (message "") | |
260 (nconc rest articles))) | |
261 | |
15511 | 262 (deffoo nnmh-close-group (group &optional server) |
13401 | 263 t) |
264 | |
15511 | 265 (deffoo nnmh-request-move-article |
13401 | 266 (article group server accept-form &optional last) |
267 (let ((buf (get-buffer-create " *nnmh move*")) | |
268 result) | |
269 (and | |
15511 | 270 (nnmh-deletable-article-p group article) |
13401 | 271 (nnmh-request-article article group server) |
272 (save-excursion | |
273 (set-buffer buf) | |
274 (insert-buffer-substring nntp-server-buffer) | |
275 (setq result (eval accept-form)) | |
276 (kill-buffer (current-buffer)) | |
277 result) | |
15511 | 278 (progn |
279 (nnmh-possibly-change-directory group server) | |
280 (condition-case () | |
281 (funcall nnmail-delete-file-function | |
282 (concat nnmh-current-directory (int-to-string article))) | |
283 (file-error nil)))) | |
13401 | 284 result)) |
285 | |
15511 | 286 (deffoo nnmh-request-accept-article (group &optional server last noinsert) |
287 (nnmh-possibly-change-directory group server) | |
288 (nnmail-check-syntax) | |
13401 | 289 (if (stringp group) |
290 (and | |
291 (nnmail-activate 'nnmh) | |
292 ;; We trick the choosing function into believing that only one | |
14040 | 293 ;; group is available. |
13401 | 294 (let ((nnmail-split-methods (list (list group "")))) |
15511 | 295 (car (nnmh-save-mail noinsert)))) |
13401 | 296 (and |
297 (nnmail-activate 'nnmh) | |
15511 | 298 (car (nnmh-save-mail noinsert))))) |
13401 | 299 |
15511 | 300 (deffoo nnmh-request-replace-article (article group buffer) |
13401 | 301 (nnmh-possibly-change-directory group) |
302 (save-excursion | |
303 (set-buffer buffer) | |
304 (nnmh-possibly-create-directory group) | |
305 (condition-case () | |
306 (progn | |
15511 | 307 (write-region |
308 (point-min) (point-max) | |
309 (concat nnmh-current-directory (int-to-string article)) | |
310 nil (if (nnheader-be-verbose 5) nil 'nomesg)) | |
13401 | 311 t) |
312 (error nil)))) | |
313 | |
15511 | 314 (deffoo nnmh-request-create-group (group &optional server) |
315 (nnmail-activate 'nnmh) | |
316 (or (assoc group nnmh-group-alist) | |
317 (let (active) | |
318 (setq nnmh-group-alist (cons (list group (setq active (cons 1 0))) | |
319 nnmh-group-alist)) | |
320 (nnmh-possibly-create-directory group) | |
321 (nnmh-possibly-change-directory group server) | |
322 (let ((articles (mapcar | |
323 (lambda (file) | |
324 (string-to-int file)) | |
325 (directory-files | |
326 nnmh-current-directory nil "^[0-9]+$")))) | |
327 (and articles | |
328 (progn | |
329 (setcar active (apply 'min articles)) | |
330 (setcdr active (apply 'max articles))))))) | |
331 t) | |
332 | |
333 (deffoo nnmh-request-delete-group (group &optional force server) | |
334 (nnmh-possibly-change-directory group server) | |
335 ;; Delete all articles in GROUP. | |
336 (if (not force) | |
337 () ; Don't delete the articles. | |
338 (let ((articles (directory-files nnmh-current-directory t "^[0-9]+$"))) | |
339 (while articles | |
340 (and (file-writable-p (car articles)) | |
341 (progn | |
342 (nnheader-message 5 "Deleting article %s in %s..." | |
343 (car articles) group) | |
344 (funcall nnmail-delete-file-function (car articles)))) | |
345 (setq articles (cdr articles)))) | |
346 ;; Try to delete the directory itself. | |
347 (condition-case () | |
348 (delete-directory nnmh-current-directory) | |
349 (error nil))) | |
350 ;; Remove the group from all structures. | |
351 (setq nnmh-group-alist | |
352 (delq (assoc group nnmh-group-alist) nnmh-group-alist) | |
353 nnmh-current-directory nil) | |
354 t) | |
355 | |
356 (deffoo nnmh-request-rename-group (group new-name &optional server) | |
357 (nnmh-possibly-change-directory group server) | |
358 ;; Rename directory. | |
359 (and (file-writable-p nnmh-current-directory) | |
360 (condition-case () | |
361 (progn | |
362 (rename-file | |
363 (directory-file-name nnmh-current-directory) | |
364 (directory-file-name | |
365 (nnmail-group-pathname new-name nnmh-directory))) | |
366 t) | |
367 (error nil)) | |
368 ;; That went ok, so we change the internal structures. | |
369 (let ((entry (assoc group nnmh-group-alist))) | |
370 (and entry (setcar entry new-name)) | |
371 (setq nnmh-current-directory nil) | |
372 t))) | |
373 | |
13401 | 374 |
375 ;;; Internal functions. | |
376 | |
15511 | 377 (defun nnmh-possibly-change-directory (newsgroup &optional server) |
378 (when (and server | |
379 (not (nnmh-server-opened server))) | |
380 (nnmh-open-server server)) | |
13401 | 381 (if newsgroup |
15511 | 382 (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory))) |
13401 | 383 (if (file-directory-p pathname) |
384 (setq nnmh-current-directory pathname) | |
385 (error "No such newsgroup: %s" newsgroup))))) | |
386 | |
387 (defun nnmh-possibly-create-directory (group) | |
388 (let (dir dirs) | |
15511 | 389 (setq dir (nnmail-group-pathname group nnmh-directory)) |
13401 | 390 (while (not (file-directory-p dir)) |
391 (setq dirs (cons dir dirs)) | |
392 (setq dir (file-name-directory (directory-file-name dir)))) | |
393 (while dirs | |
394 (if (make-directory (directory-file-name (car dirs))) | |
395 (error "Could not create directory %s" (car dirs))) | |
15511 | 396 (nnheader-message 5 "Creating mail directory %s" (car dirs)) |
13401 | 397 (setq dirs (cdr dirs))))) |
398 | |
15511 | 399 (defun nnmh-save-mail (&optional noinsert) |
13401 | 400 "Called narrowed to an article." |
401 (let ((group-art (nreverse (nnmail-article-group 'nnmh-active-number)))) | |
15511 | 402 (unless noinsert |
403 (nnmail-insert-lines) | |
404 (nnmail-insert-xref group-art)) | |
405 (run-hooks 'nnmail-prepare-save-mail-hook) | |
13401 | 406 (run-hooks 'nnmh-prepare-save-mail-hook) |
407 (goto-char (point-min)) | |
408 (while (looking-at "From ") | |
409 (replace-match "X-From-Line: ") | |
410 (forward-line 1)) | |
411 ;; We save the article in all the newsgroups it belongs in. | |
412 (let ((ga group-art) | |
413 first) | |
414 (while ga | |
15511 | 415 (nnmh-possibly-create-directory (caar ga)) |
416 (let ((file (concat (nnmail-group-pathname | |
417 (caar ga) nnmh-directory) | |
418 (int-to-string (cdar ga))))) | |
13401 | 419 (if first |
420 ;; It was already saved, so we just make a hard link. | |
15511 | 421 (funcall nnmail-crosspost-link-function first file t) |
13401 | 422 ;; Save the article. |
423 (write-region (point-min) (point-max) file nil nil) | |
424 (setq first file))) | |
425 (setq ga (cdr ga)))) | |
426 group-art)) | |
427 | |
428 (defun nnmh-active-number (group) | |
429 "Compute the next article number in GROUP." | |
15511 | 430 (let ((active (cadr (assoc group nnmh-group-alist)))) |
13401 | 431 ;; The group wasn't known to nnmh, so we just create an active |
432 ;; entry for it. | |
433 (or active | |
434 (progn | |
435 (setq active (cons 1 0)) | |
436 (setq nnmh-group-alist (cons (list group active) nnmh-group-alist)))) | |
437 (setcdr active (1+ (cdr active))) | |
438 (while (file-exists-p | |
15511 | 439 (concat (nnmail-group-pathname group nnmh-directory) |
13401 | 440 (int-to-string (cdr active)))) |
441 (setcdr active (1+ (cdr active)))) | |
442 (cdr active))) | |
443 | |
444 (defun nnmh-update-gnus-unreads (group) | |
445 ;; Go through the .nnmh-articles file and compare with the actual | |
446 ;; articles in this folder. The articles that are "new" will be | |
447 ;; marked as unread by Gnus. | |
448 (let* ((dir nnmh-current-directory) | |
449 (files (sort (mapcar (function (lambda (name) (string-to-int name))) | |
450 (directory-files nnmh-current-directory | |
451 nil "^[0-9]+$" t)) '<)) | |
452 (nnmh-file (concat dir ".nnmh-articles")) | |
453 new articles) | |
454 ;; Load the .nnmh-articles file. | |
455 (if (file-exists-p nnmh-file) | |
456 (setq articles | |
457 (let (nnmh-newsgroup-articles) | |
458 (condition-case nil (load nnmh-file nil t t) (error nil)) | |
459 nnmh-newsgroup-articles))) | |
460 ;; Add all new articles to the `new' list. | |
461 (let ((art files)) | |
462 (while art | |
463 (if (not (assq (car art) articles)) (setq new (cons (car art) new))) | |
464 (setq art (cdr art)))) | |
465 ;; Remove all deleted articles. | |
466 (let ((art articles)) | |
467 (while art | |
15511 | 468 (if (not (memq (caar art) files)) |
13401 | 469 (setq articles (delq (car art) articles))) |
470 (setq art (cdr art)))) | |
471 ;; Check whether the highest-numbered articles really are the ones | |
472 ;; that Gnus thinks they are by looking at the time-stamps. | |
473 (let ((art articles)) | |
474 (while (and art | |
475 (not (equal | |
476 (nth 5 (file-attributes | |
15511 | 477 (concat dir (int-to-string (caar art))))) |
478 (cdar art)))) | |
13401 | 479 (setq articles (delq (car art) articles)) |
15511 | 480 (setq new (cons (caar art) new)) |
13401 | 481 (setq art (cdr art)))) |
482 ;; Go through all the new articles and add them, and their | |
483 ;; time-stamps to the list. | |
484 (let ((n new)) | |
485 (while n | |
486 (setq articles | |
487 (cons (cons | |
488 (car n) | |
489 (nth 5 (file-attributes | |
490 (concat dir (int-to-string (car n)))))) | |
491 articles)) | |
492 (setq n (cdr n)))) | |
493 ;; Make Gnus mark all new articles as unread. | |
494 (or (zerop (length new)) | |
495 (gnus-make-articles-unread | |
496 (gnus-group-prefixed-name group (list 'nnmh "")) | |
497 (setq new (sort new '<)))) | |
498 ;; Sort the article list with highest numbers first. | |
499 (setq articles (sort articles (lambda (art1 art2) | |
500 (> (car art1) (car art2))))) | |
501 ;; Finally write this list back to the .nnmh-articles file. | |
502 (save-excursion | |
503 (set-buffer (get-buffer-create "*nnmh out*")) | |
504 (insert ";; Gnus article active file for " group "\n\n") | |
505 (insert "(setq nnmh-newsgroup-articles '") | |
506 (insert (prin1-to-string articles) ")\n") | |
507 (write-region (point-min) (point-max) nnmh-file nil 'nomesg) | |
508 (kill-buffer (current-buffer))))) | |
509 | |
15511 | 510 (defun nnmh-deletable-article-p (group article) |
511 "Say whether ARTICLE in GROUP can be deleted." | |
512 (let ((path (concat nnmh-current-directory (int-to-string article)))) | |
513 (and (file-writable-p path) | |
514 (or (not nnmail-keep-last-article) | |
515 (not (eq (cdr (nth 1 (assoc group nnmh-group-alist))) | |
516 article)))))) | |
517 | |
13401 | 518 (provide 'nnmh) |
519 | |
520 ;;; nnmh.el ends here |