2000-11-29 20:00:00 ShengHuo ZHU <zsh@cs.rochester.edu>
[gnus] / lisp / nnmbox.el
1 ;;; nnmbox.el --- mail mbox access for Gnus
2 ;; Copyright (C) 1995,96,97,98,99 Free Software Foundation, Inc.
3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
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 ;; You should have received a copy of the GNU General Public License
16 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
17 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18 ;; Boston, MA 02111-1307, USA.
19
20 ;;; Commentary:
21
22 ;; For an overview of what the interface functions do, please see the
23 ;; Gnus sources.
24
25 ;;; Code:
26
27 (require 'nnheader)
28 (require 'message)
29 (require 'nnmail)
30 (require 'nnoo)
31 (eval-when-compile (require 'cl))
32
33 (nnoo-declare nnmbox)
34
35 (defvoo nnmbox-mbox-file (expand-file-name "~/mbox")
36   "The name of the mail box file in the user's home directory.")
37
38 (defvoo nnmbox-active-file (expand-file-name "~/.mbox-active")
39   "The name of the active file for the mail box.")
40
41 (defvoo nnmbox-get-new-mail t
42   "If non-nil, nnmbox will check the incoming mail file and split the mail.")
43
44 (defvoo nnmbox-prepare-save-mail-hook nil
45   "Hook run narrowed to an article before saving.")
46
47 \f
48
49 (defconst nnmbox-version "nnmbox 1.0"
50   "nnmbox version.")
51
52 (defvoo nnmbox-current-group nil
53   "Current nnmbox news group directory.")
54
55 (defconst nnmbox-mbox-buffer nil)
56
57 (defvoo nnmbox-status-string "")
58
59 (defvoo nnmbox-group-alist nil)
60 (defvoo nnmbox-active-timestamp nil)
61
62 (defvoo nnmbox-file-coding-system mm-text-coding-system)
63 (defvoo nnmbox-file-coding-system-for-write nil)
64 (defvoo nnmbox-active-file-coding-system mm-text-coding-system)
65 (defvoo nnmbox-active-file-coding-system-for-write nil)
66
67 \f
68
69 ;;; Interface functions
70
71 (nnoo-define-basics nnmbox)
72
73 (deffoo nnmbox-retrieve-headers (sequence &optional newsgroup server fetch-old)
74   (save-excursion
75     (set-buffer nntp-server-buffer)
76     (erase-buffer)
77     (let ((number (length sequence))
78           (count 0)
79           article art-string start stop)
80       (nnmbox-possibly-change-newsgroup newsgroup server)
81       (while sequence
82         (setq article (car sequence))
83         (setq art-string (nnmbox-article-string article))
84         (set-buffer nnmbox-mbox-buffer)
85         (when (or (search-forward art-string nil t)
86                   (progn (goto-char (point-min))
87                          (search-forward art-string nil t)))
88           (setq start
89                 (save-excursion
90                   (re-search-backward
91                    (concat "^" message-unix-mail-delimiter) nil t)
92                   (point)))
93           (search-forward "\n\n" nil t)
94           (setq stop (1- (point)))
95           (set-buffer nntp-server-buffer)
96           (insert (format "221 %d Article retrieved.\n" article))
97           (insert-buffer-substring nnmbox-mbox-buffer start stop)
98           (goto-char (point-max))
99           (insert ".\n"))
100         (setq sequence (cdr sequence))
101         (setq count (1+ count))
102         (and (numberp nnmail-large-newsgroup)
103              (> number nnmail-large-newsgroup)
104              (zerop (% count 20))
105              (nnheader-message 5 "nnmbox: Receiving headers... %d%%"
106                                (/ (* count 100) number))))
107
108       (and (numberp nnmail-large-newsgroup)
109            (> number nnmail-large-newsgroup)
110            (nnheader-message 5 "nnmbox: Receiving headers...done"))
111
112       (set-buffer nntp-server-buffer)
113       (nnheader-fold-continuation-lines)
114       'headers)))
115
116 (deffoo nnmbox-open-server (server &optional defs)
117   (nnoo-change-server 'nnmbox server defs)
118   (nnmbox-create-mbox)
119   (cond
120    ((not (file-exists-p nnmbox-mbox-file))
121     (nnmbox-close-server)
122     (nnheader-report 'nnmbox "No such file: %s" nnmbox-mbox-file))
123    ((file-directory-p nnmbox-mbox-file)
124     (nnmbox-close-server)
125     (nnheader-report 'nnmbox "Not a regular file: %s" nnmbox-mbox-file))
126    (t
127     (nnheader-report 'nnmbox "Opened server %s using mbox %s" server
128                      nnmbox-mbox-file)
129     t)))
130
131 (deffoo nnmbox-close-server (&optional server)
132   (when (and nnmbox-mbox-buffer
133              (buffer-name nnmbox-mbox-buffer))
134     (kill-buffer nnmbox-mbox-buffer))
135   (nnoo-close-server 'nnmbox server)
136   t)
137
138 (deffoo nnmbox-server-opened (&optional server)
139   (and (nnoo-current-server-p 'nnmbox server)
140        nnmbox-mbox-buffer
141        (buffer-name nnmbox-mbox-buffer)
142        nntp-server-buffer
143        (buffer-name nntp-server-buffer)))
144
145 (deffoo nnmbox-request-article (article &optional newsgroup server buffer)
146   (nnmbox-possibly-change-newsgroup newsgroup server)
147   (save-excursion
148     (set-buffer nnmbox-mbox-buffer)
149     (goto-char (point-min))
150     (when (search-forward (nnmbox-article-string article) nil t)
151       (let (start stop)
152         (re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
153         (setq start (point))
154         (forward-line 1)
155         (or (and (re-search-forward
156                   (concat "^" message-unix-mail-delimiter) nil t)
157                  (forward-line -1))
158             (goto-char (point-max)))
159         (setq stop (point))
160         (let ((nntp-server-buffer (or buffer nntp-server-buffer)))
161           (set-buffer nntp-server-buffer)
162           (erase-buffer)
163           (insert-buffer-substring nnmbox-mbox-buffer start stop)
164           (goto-char (point-min))
165           (while (looking-at "From ")
166             (delete-char 5)
167             (insert "X-From-Line: ")
168             (forward-line 1))
169           (if (numberp article)
170               (cons nnmbox-current-group article)
171             (nnmbox-article-group-number)))))))
172
173 (deffoo nnmbox-request-group (group &optional server dont-check)
174   (nnmbox-possibly-change-newsgroup nil server)
175   (let ((active (cadr (assoc group nnmbox-group-alist))))
176     (cond
177      ((or (null active)
178           (null (nnmbox-possibly-change-newsgroup group server)))
179       (nnheader-report 'nnmbox "No such group: %s" group))
180      (dont-check
181       (nnheader-report 'nnmbox "Selected group %s" group)
182       (nnheader-insert ""))
183      (t
184       (nnheader-report 'nnmbox "Selected group %s" group)
185       (nnheader-insert "211 %d %d %d %s\n"
186                        (1+ (- (cdr active) (car active)))
187                        (car active) (cdr active) group)))))
188
189 (defun nnmbox-save-buffer ()
190   (let ((coding-system-for-write 
191          (or nnmbox-file-coding-system-for-write
192              nnmbox-file-coding-system)))
193     (save-buffer)))
194
195 (defun nnmbox-save-active (group-alist active-file)
196   (let ((nnmail-active-file-coding-system
197          (or nnmbox-active-file-coding-system-for-write
198              nnmbox-active-file-coding-system)))
199     (nnmail-save-active group-alist active-file)))
200
201 (deffoo nnmbox-request-scan (&optional group server)
202   (nnmbox-possibly-change-newsgroup group server)
203   (nnmbox-read-mbox)
204   (nnmail-get-new-mail
205    'nnmbox
206    (lambda ()
207      (save-excursion
208        (set-buffer nnmbox-mbox-buffer)
209        (nnmbox-save-buffer)))
210    (file-name-directory nnmbox-mbox-file)
211    group
212    (lambda ()
213      (save-excursion
214        (let ((in-buf (current-buffer)))
215          (set-buffer nnmbox-mbox-buffer)
216          (goto-char (point-max))
217          (insert-buffer-substring in-buf)))
218      (nnmbox-save-active nnmbox-group-alist nnmbox-active-file))))
219
220 (deffoo nnmbox-close-group (group &optional server)
221   t)
222
223 (deffoo nnmbox-request-create-group (group &optional server args)
224   (nnmail-activate 'nnmbox)
225   (unless (assoc group nnmbox-group-alist)
226     (push (list group (cons 1 0))
227           nnmbox-group-alist)
228     (nnmbox-save-active nnmbox-group-alist nnmbox-active-file))
229   t)
230
231 (deffoo nnmbox-request-list (&optional server)
232   (save-excursion
233     (let ((nnmail-file-coding-system
234            nnmbox-active-file-coding-system))
235       (nnmail-find-file nnmbox-active-file))
236     (setq nnmbox-group-alist (nnmail-get-active))
237     t))
238
239 (deffoo nnmbox-request-newgroups (date &optional server)
240   (nnmbox-request-list server))
241
242 (deffoo nnmbox-request-list-newsgroups (&optional server)
243   (nnheader-report 'nnmbox "LIST NEWSGROUPS is not implemented."))
244
245 (deffoo nnmbox-request-expire-articles
246     (articles newsgroup &optional server force)
247   (nnmbox-possibly-change-newsgroup newsgroup server)
248   (let* ((is-old t)
249          rest)
250     (nnmail-activate 'nnmbox)
251
252     (save-excursion
253       (set-buffer nnmbox-mbox-buffer)
254       (while (and articles is-old)
255         (goto-char (point-min))
256         (when (search-forward (nnmbox-article-string (car articles)) nil t)
257           (if (setq is-old
258                     (nnmail-expired-article-p
259                      newsgroup
260                      (buffer-substring
261                       (point) (progn (end-of-line) (point))) force))
262               (progn
263                 (unless (eq nnmail-expiry-target 'delete)
264                   (with-temp-buffer
265                     (nnmbox-request-article (car articles) 
266                                              newsgroup server 
267                                              (current-buffer))
268                     (let ((nnml-current-directory nil))
269                       (nnmail-expiry-target-group
270                        nnmail-expiry-target newsgroup))))
271                 (nnheader-message 5 "Deleting article %d in %s..."
272                                   (car articles) newsgroup)
273                 (nnmbox-delete-mail))
274             (push (car articles) rest)))
275         (setq articles (cdr articles)))
276       (nnmbox-save-buffer)
277       ;; Find the lowest active article in this group.
278       (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist))))
279         (goto-char (point-min))
280         (while (and (not (search-forward
281                           (nnmbox-article-string (car active)) nil t))
282                     (<= (car active) (cdr active)))
283           (setcar active (1+ (car active)))
284           (goto-char (point-min))))
285       (nnmbox-save-active nnmbox-group-alist nnmbox-active-file)
286       (nconc rest articles))))
287
288 (deffoo nnmbox-request-move-article
289     (article group server accept-form &optional last)
290   (let ((buf (get-buffer-create " *nnmbox move*"))
291         result)
292     (and
293      (nnmbox-request-article article group server)
294      (save-excursion
295        (set-buffer buf)
296        (erase-buffer)
297        (insert-buffer-substring nntp-server-buffer)
298        (goto-char (point-min))
299        (while (re-search-forward
300                "^X-Gnus-Newsgroup:"
301                (save-excursion (search-forward "\n\n" nil t) (point)) t)
302          (delete-region (progn (beginning-of-line) (point))
303                         (progn (forward-line 1) (point))))
304        (setq result (eval accept-form))
305        (kill-buffer buf)
306        result)
307      (save-excursion
308        (nnmbox-possibly-change-newsgroup group server)
309        (set-buffer nnmbox-mbox-buffer)
310        (goto-char (point-min))
311        (when (search-forward (nnmbox-article-string article) nil t)
312          (nnmbox-delete-mail))
313        (and last (nnmbox-save-buffer))))
314     result))
315
316 (deffoo nnmbox-request-accept-article (group &optional server last)
317   (nnmbox-possibly-change-newsgroup group server)
318   (nnmail-check-syntax)
319   (let ((buf (current-buffer))
320         result)
321     (goto-char (point-min))
322     ;; The From line may have been quoted by movemail.
323     (when (looking-at (concat ">" message-unix-mail-delimiter))
324       (delete-char 1))
325     (if (looking-at "X-From-Line: ")
326         (replace-match "From ")
327       (insert "From nobody " (current-time-string) "\n"))
328     (and
329      (nnmail-activate 'nnmbox)
330      (progn
331        (set-buffer buf)
332        (goto-char (point-min))
333        (search-forward "\n\n" nil t)
334        (forward-line -1)
335        (while (re-search-backward "^X-Gnus-Newsgroup: " nil t)
336          (delete-region (point) (progn (forward-line 1) (point))))
337        (when nnmail-cache-accepted-message-ids
338          (nnmail-cache-insert (nnmail-fetch-field "message-id")))
339        (setq result (if (stringp group)
340                         (list (cons group (nnmbox-active-number group)))
341                       (nnmail-article-group 'nnmbox-active-number)))
342        (if (and (null result)
343                 (yes-or-no-p "Moved to `junk' group; delete article? "))
344            (setq result 'junk)
345          (setq result (car (nnmbox-save-mail result)))))
346      (save-excursion
347        (set-buffer nnmbox-mbox-buffer)
348        (goto-char (point-max))
349        (insert-buffer-substring buf)
350        (when last
351          (when nnmail-cache-accepted-message-ids
352            (nnmail-cache-close))
353          (nnmbox-save-active nnmbox-group-alist nnmbox-active-file)
354          (nnmbox-save-buffer))))
355     result))
356
357 (deffoo nnmbox-request-replace-article (article group buffer)
358   (nnmbox-possibly-change-newsgroup group)
359   (save-excursion
360     (set-buffer nnmbox-mbox-buffer)
361     (goto-char (point-min))
362     (if (not (search-forward (nnmbox-article-string article) nil t))
363         nil
364       (nnmbox-delete-mail t t)
365       (insert-buffer-substring buffer)
366       (nnmbox-save-buffer)
367       t)))
368
369 (deffoo nnmbox-request-delete-group (group &optional force server)
370   (nnmbox-possibly-change-newsgroup group server)
371   ;; Delete all articles in GROUP.
372   (if (not force)
373       ()                                ; Don't delete the articles.
374     (save-excursion
375       (set-buffer nnmbox-mbox-buffer)
376       (goto-char (point-min))
377       ;; Delete all articles in this group.
378       (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"))
379             found)
380         (while (search-forward ident nil t)
381           (setq found t)
382           (nnmbox-delete-mail))
383         (when found
384           (nnmbox-save-buffer)))))
385   ;; Remove the group from all structures.
386   (setq nnmbox-group-alist
387         (delq (assoc group nnmbox-group-alist) nnmbox-group-alist)
388         nnmbox-current-group nil)
389   ;; Save the active file.
390   (nnmbox-save-active nnmbox-group-alist nnmbox-active-file)
391   t)
392
393 (deffoo nnmbox-request-rename-group (group new-name &optional server)
394   (nnmbox-possibly-change-newsgroup group server)
395   (save-excursion
396     (set-buffer nnmbox-mbox-buffer)
397     (goto-char (point-min))
398     (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"))
399           (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":"))
400           found)
401       (while (search-forward ident nil t)
402         (replace-match new-ident t t)
403         (setq found t))
404       (when found
405         (nnmbox-save-buffer))))
406   (let ((entry (assoc group nnmbox-group-alist)))
407     (when entry
408       (setcar entry new-name))
409     (setq nnmbox-current-group nil)
410     ;; Save the new group alist.
411     (nnmbox-save-active nnmbox-group-alist nnmbox-active-file)
412     t))
413
414 \f
415 ;;; Internal functions.
416
417 ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
418 ;; headers there are.  If LEAVE-DELIM, don't delete the Unix mbox
419 ;; delimiter line.
420 (defun nnmbox-delete-mail (&optional force leave-delim)
421   ;; Delete the current X-Gnus-Newsgroup line.
422   (or force
423       (delete-region
424        (progn (beginning-of-line) (point))
425        (progn (forward-line 1) (point))))
426   ;; Beginning of the article.
427   (save-excursion
428     (save-restriction
429       (narrow-to-region
430        (save-excursion
431          (re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
432          (if leave-delim (progn (forward-line 1) (point))
433            (match-beginning 0)))
434        (progn
435          (forward-line 1)
436          (or (and (re-search-forward (concat "^" message-unix-mail-delimiter)
437                                      nil t)
438                   (if (and (not (bobp)) leave-delim)
439                       (progn (forward-line -2) (point))
440                     (match-beginning 0)))
441              (point-max))))
442       (goto-char (point-min))
443       ;; Only delete the article if no other groups owns it as well.
444       (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
445         (delete-region (point-min) (point-max))))))
446
447 (defun nnmbox-possibly-change-newsgroup (newsgroup &optional server)
448   (when (and server
449              (not (nnmbox-server-opened server)))
450     (nnmbox-open-server server))
451   (when (or (not nnmbox-mbox-buffer)
452             (not (buffer-name nnmbox-mbox-buffer)))
453     (save-excursion
454       (set-buffer (setq nnmbox-mbox-buffer
455                         (let ((nnheader-file-coding-system
456                                nnmbox-file-coding-system))
457                           (nnheader-find-file-noselect
458                            nnmbox-mbox-file nil t))))
459       (mm-enable-multibyte)
460       (buffer-disable-undo)))
461   (when (not nnmbox-group-alist)
462     (nnmail-activate 'nnmbox))
463   (if newsgroup
464       (when (assoc newsgroup nnmbox-group-alist)
465         (setq nnmbox-current-group newsgroup))
466     t))
467
468 (defun nnmbox-article-string (article)
469   (if (numberp article)
470       (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"
471               (int-to-string article) " ")
472     (concat "\nMessage-ID: " article)))
473
474 (defun nnmbox-article-group-number ()
475   (save-excursion
476     (goto-char (point-min))
477     (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
478                              nil t)
479       (cons (buffer-substring (match-beginning 1) (match-end 1))
480             (string-to-int
481              (buffer-substring (match-beginning 2) (match-end 2)))))))
482
483 (defun nnmbox-save-mail (group-art)
484   "Called narrowed to an article."
485   (let ((delim (concat "^" message-unix-mail-delimiter)))
486     (goto-char (point-min))
487     ;; This might come from somewhere else.
488     (unless (looking-at delim)
489       (insert "From nobody " (current-time-string) "\n")
490       (goto-char (point-min)))
491     ;; Quote all "From " lines in the article.
492     (forward-line 1)
493     (while (re-search-forward delim nil t)
494       (beginning-of-line)
495       (insert "> "))
496     (nnmail-insert-lines)
497     (nnmail-insert-xref group-art)
498     (nnmbox-insert-newsgroup-line group-art)
499     (run-hooks 'nnmail-prepare-save-mail-hook)
500     (run-hooks 'nnmbox-prepare-save-mail-hook)
501     group-art))
502
503 (defun nnmbox-insert-newsgroup-line (group-art)
504   (save-excursion
505     (goto-char (point-min))
506     (when (search-forward "\n\n" nil t)
507       (forward-char -1)
508       (while group-art
509         (insert (format "X-Gnus-Newsgroup: %s:%d   %s\n"
510                         (caar group-art) (cdar group-art)
511                         (current-time-string)))
512         (setq group-art (cdr group-art))))
513     t))
514
515 (defun nnmbox-active-number (group)
516   ;; Find the next article number in GROUP.
517   (let ((active (cadr (assoc group nnmbox-group-alist))))
518     (if active
519         (setcdr active (1+ (cdr active)))
520       ;; This group is new, so we create a new entry for it.
521       ;; This might be a bit naughty... creating groups on the drop of
522       ;; a hat, but I don't know...
523       (push (list group (setq active (cons 1 1)))
524             nnmbox-group-alist))
525     (cdr active)))
526
527 (defun nnmbox-create-mbox ()
528   (when (not (file-exists-p nnmbox-mbox-file))
529     (let ((nnmail-file-coding-system
530            (or nnmbox-file-coding-system-for-write
531                nnmbox-file-coding-system)))
532       (nnmail-write-region 1 1 nnmbox-mbox-file t 'nomesg))))
533
534 (defun nnmbox-read-mbox ()
535   (nnmail-activate 'nnmbox)
536   (nnmbox-create-mbox)
537   (if (and nnmbox-mbox-buffer
538            (buffer-name nnmbox-mbox-buffer)
539            (save-excursion
540              (set-buffer nnmbox-mbox-buffer)
541              (= (buffer-size) (nnheader-file-size nnmbox-mbox-file))))
542       ()
543     (save-excursion
544       (let ((delim (concat "^" message-unix-mail-delimiter))
545             (alist nnmbox-group-alist)
546             start end number)
547         (set-buffer (setq nnmbox-mbox-buffer
548                           (let ((nnheader-file-coding-system
549                                  nnmbox-file-coding-system))
550                             (nnheader-find-file-noselect
551                              nnmbox-mbox-file nil t))))
552         (mm-enable-multibyte)
553         (buffer-disable-undo)
554
555         ;; Go through the group alist and compare against
556         ;; the mbox file.
557         (while alist
558           (goto-char (point-max))
559           (when (and (re-search-backward
560                       (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) "
561                               (caar alist)) nil t)
562                      (> (setq number
563                               (string-to-number
564                                (buffer-substring
565                                 (match-beginning 1) (match-end 1))))
566                         (cdadar alist)))
567             (setcdr (cadar alist) number))
568           (setq alist (cdr alist)))
569
570         (goto-char (point-min))
571         (while (re-search-forward delim nil t)
572           (setq start (match-beginning 0))
573           (unless (search-forward
574                    "\nX-Gnus-Newsgroup: "
575                    (save-excursion
576                      (setq end
577                            (or
578                             (and
579                              ;; skip to end of headers first, since mail
580                              ;; which has been respooled has additional
581                              ;; "From nobody" lines.
582                              (search-forward "\n\n" nil t)
583                              (re-search-forward delim nil t)
584                              (match-beginning 0))
585                             (point-max))))
586                    t)
587             (save-excursion
588               (save-restriction
589                 (narrow-to-region start end)
590                 (nnmbox-save-mail
591                  (nnmail-article-group 'nnmbox-active-number)))))
592           (goto-char end))))))
593
594 (provide 'nnmbox)
595
596 ;;; nnmbox.el ends here