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