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