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