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