a70a0395f3707d7ba0c54f8a7058d33cd53803b8
[gnus] / lisp / nnmbox.el
1 ;;; nnmbox.el --- mail mbox access for Gnus
2
3 ;; Copyright (C) 1995-2015 Free Software Foundation, Inc.
4
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;;      Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
7 ;; Keywords: news, mail
8
9 ;; This file is part of GNU Emacs.
10
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
15
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19 ;; GNU General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
23
24 ;;; Commentary:
25
26 ;; For an overview of what the interface functions do, please see the
27 ;; Gnus sources.
28
29 ;;; Code:
30
31 (require 'nnheader)
32 (require 'message)
33 (require 'nnmail)
34 (require 'nnoo)
35 (require 'gnus-range)
36 (eval-when-compile (require 'cl))
37
38 (nnoo-declare nnmbox)
39
40 (defvoo nnmbox-mbox-file (expand-file-name "~/mbox")
41   "The name of the mail box file in the user's home directory.")
42
43 (defvoo nnmbox-active-file (expand-file-name "~/.mbox-active")
44   "The name of the active file for the mail box.")
45
46 (defvoo nnmbox-get-new-mail t
47   "If non-nil, nnmbox will check the incoming mail file and split the mail.")
48
49 (defvoo nnmbox-prepare-save-mail-hook nil
50   "Hook run narrowed to an article before saving.")
51
52 \f
53
54 (defconst nnmbox-version "nnmbox 1.0"
55   "nnmbox version.")
56
57 (defvoo nnmbox-current-group nil
58   "Current nnmbox news group directory.")
59
60 (defvar nnmbox-mbox-buffer nil)
61
62 (defvoo nnmbox-status-string "")
63
64 (defvoo nnmbox-group-alist nil)
65 (defvoo nnmbox-active-timestamp nil)
66
67 (defvoo nnmbox-file-coding-system mm-binary-coding-system)
68 (defvoo nnmbox-file-coding-system-for-write nil)
69 (defvoo nnmbox-active-file-coding-system mm-binary-coding-system)
70 (defvoo nnmbox-active-file-coding-system-for-write nil)
71
72 (defvar nnmbox-group-building-active-articles nil)
73 (defvar nnmbox-group-active-articles nil)
74 \f
75
76 ;;; Interface functions
77
78 (nnoo-define-basics nnmbox)
79
80 (deffoo nnmbox-retrieve-headers (sequence &optional newsgroup server fetch-old)
81   (with-current-buffer nntp-server-buffer
82     (erase-buffer)
83     (let ((number (length sequence))
84           (count 0)
85           article start stop)
86       (nnmbox-possibly-change-newsgroup newsgroup server)
87       (while sequence
88         (setq article (car sequence))
89         (set-buffer nnmbox-mbox-buffer)
90         (when (nnmbox-find-article article)
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                                (floor (* count 100.0) 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   (with-current-buffer nnmbox-mbox-buffer
151     (save-excursion
152       (when (nnmbox-find-article article)
153         (let (start stop)
154           (re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
155           (setq start (point))
156           (forward-line 1)
157           (setq stop (if (re-search-forward (concat "^"
158                                                     message-unix-mail-delimiter)
159                                             nil 'move)
160                          (match-beginning 0)
161                        (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 nil))))))))
174
175 (deffoo nnmbox-request-group (group &optional server dont-check info)
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      (with-current-buffer nnmbox-mbox-buffer
210        (nnmbox-save-buffer)))
211    (file-name-directory nnmbox-mbox-file)
212    group
213    (lambda ()
214      (save-excursion
215        (let ((in-buf (current-buffer)))
216          (set-buffer nnmbox-mbox-buffer)
217          (goto-char (point-max))
218          (insert-buffer-substring in-buf)))
219      (nnmbox-save-active nnmbox-group-alist nnmbox-active-file))))
220
221 (deffoo nnmbox-close-group (group &optional server)
222   t)
223
224 (deffoo nnmbox-request-create-group (group &optional server args)
225   (nnmail-activate 'nnmbox)
226   (unless (assoc group nnmbox-group-alist)
227     (push (list group (cons 1 0))
228           nnmbox-group-alist)
229     (nnmbox-save-active nnmbox-group-alist nnmbox-active-file))
230   t)
231
232 (deffoo nnmbox-request-list (&optional server)
233   (save-excursion
234     (let ((nnmail-file-coding-system
235            nnmbox-active-file-coding-system))
236       (nnmail-find-file nnmbox-active-file))
237     (setq nnmbox-group-alist (nnmail-get-active))
238     t))
239
240 (deffoo nnmbox-request-newgroups (date &optional server)
241   (nnmbox-request-list server))
242
243 (deffoo nnmbox-request-list-newsgroups (&optional server)
244   (nnheader-report 'nnmbox "LIST NEWSGROUPS is not implemented."))
245
246 (deffoo nnmbox-request-expire-articles
247     (articles newsgroup &optional server force)
248   (nnmbox-possibly-change-newsgroup newsgroup server)
249   (let* ((is-old t)
250          rest)
251     (nnmail-activate 'nnmbox)
252
253     (with-current-buffer nnmbox-mbox-buffer
254       (while (and articles is-old)
255         (when (nnmbox-find-article (car articles))
256           (if (setq is-old
257                     (nnmail-expired-article-p
258                      newsgroup
259                      (buffer-substring (point) (line-end-position))
260                      force))
261               (progn
262                 (unless (eq nnmail-expiry-target 'delete)
263                   (with-temp-buffer
264                     (nnmbox-request-article (car articles)
265                                             newsgroup server
266                                             (current-buffer))
267                     (let ((nnml-current-directory nil))
268                       (nnmail-expiry-target-group
269                        nnmail-expiry-target newsgroup)))
270                   (nnmbox-possibly-change-newsgroup newsgroup server))
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         (while (and (not (nnmbox-find-article (car active)))
280                     (<= (car active) (cdr active)))
281           (setcar active (1+ (car active)))))
282       (nnmbox-save-active nnmbox-group-alist nnmbox-active-file)
283       (nconc rest articles))))
284
285 (deffoo nnmbox-request-move-article
286     (article group server accept-form &optional last move-is-internal)
287   (let ((buf (get-buffer-create " *nnmbox move*"))
288         result)
289     (and
290      (nnmbox-request-article article group server)
291      (with-current-buffer buf
292        (erase-buffer)
293        (insert-buffer-substring nntp-server-buffer)
294        (goto-char (point-min))
295        (while (re-search-forward
296                "^X-Gnus-Newsgroup:"
297                (save-excursion (search-forward "\n\n" nil t) (point)) t)
298          (gnus-delete-line))
299        (setq result (eval accept-form))
300        (kill-buffer buf)
301        result)
302      (save-excursion
303        (nnmbox-possibly-change-newsgroup group server)
304        (set-buffer nnmbox-mbox-buffer)
305        (when (nnmbox-find-article article)
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 cont)
315     (and
316      (nnmail-activate 'nnmbox)
317      (with-temp-buffer
318        (insert-buffer-substring buf)
319        (goto-char (point-min))
320        (cond (;; The From line may have been quoted by movemail.
321               (looking-at (concat ">" message-unix-mail-delimiter))
322               (delete-char 1)
323               (forward-line 1))
324              ((looking-at "X-From-Line: ")
325               (replace-match "From ")
326               (forward-line 1))
327              (t
328               (insert "From nobody " (current-time-string) "\n")))
329        (narrow-to-region (point)
330                          (if (search-forward "\n\n" nil 'move)
331                              (1- (point))
332                            (point)))
333        (while (re-search-backward "^X-Gnus-Newsgroup: " nil t)
334          (delete-region (point) (progn (forward-line 1) (point))))
335        (when nnmail-cache-accepted-message-ids
336          (nnmail-cache-insert (message-fetch-field "message-id")
337                               group
338                               (message-fetch-field "subject")
339                               (message-fetch-field "from")))
340        (widen)
341        (setq result (if (stringp group)
342                         (list (cons group (nnmbox-active-number group)))
343                       (nnmail-article-group 'nnmbox-active-number)))
344        (prog1
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          (setq cont (buffer-string))))
350      (with-current-buffer nnmbox-mbox-buffer
351        (goto-char (point-max))
352        (insert cont)
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   (with-current-buffer nnmbox-mbox-buffer
363     (if (not (nnmbox-find-article article))
364         nil
365       (nnmbox-delete-mail t t)
366       (insert
367        (with-temp-buffer
368          (insert-buffer-substring buffer)
369          (goto-char (point-min))
370          (when (looking-at "X-From-Line:")
371            (delete-region (point) (progn (forward-line 1) (point))))
372          (while (re-search-forward (concat "^" message-unix-mail-delimiter)
373                                    nil t)
374            (goto-char (match-beginning 0))
375            (insert ">"))
376          (goto-char (point-max))
377          (unless (bolp)
378            (insert "\n"))
379          (buffer-string)))
380       (nnmbox-save-buffer)
381       t)))
382
383 (deffoo nnmbox-request-delete-group (group &optional force server)
384   (nnmbox-possibly-change-newsgroup group server)
385   ;; Delete all articles in GROUP.
386   (if (not force)
387       ()                                ; Don't delete the articles.
388     (with-current-buffer nnmbox-mbox-buffer
389       (goto-char (point-min))
390       ;; Delete all articles in this group.
391       (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"))
392             found)
393         (while (search-forward ident nil t)
394           (setq found t)
395           (nnmbox-delete-mail))
396         (when found
397           (nnmbox-save-buffer)))))
398   ;; Remove the group from all structures.
399   (setq nnmbox-group-alist
400         (delq (assoc group nnmbox-group-alist) nnmbox-group-alist)
401         nnmbox-current-group nil)
402   ;; Save the active file.
403   (nnmbox-save-active nnmbox-group-alist nnmbox-active-file)
404   t)
405
406 (deffoo nnmbox-request-rename-group (group new-name &optional server)
407   (nnmbox-possibly-change-newsgroup group server)
408   (with-current-buffer nnmbox-mbox-buffer
409     (goto-char (point-min))
410     (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"))
411           (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":"))
412           found)
413       (while (search-forward ident nil t)
414         (replace-match new-ident t t)
415         (setq found t))
416       (when found
417         (nnmbox-save-buffer))))
418   (let ((entry (assoc group nnmbox-group-active-articles)))
419     (when entry
420       (setcar entry new-name)))
421   (let ((entry (assoc group nnmbox-group-alist)))
422     (when entry
423       (setcar entry new-name))
424     (setq nnmbox-current-group nil)
425     ;; Save the new group alist.
426     (nnmbox-save-active nnmbox-group-alist nnmbox-active-file)
427     t))
428
429 \f
430 ;;; Internal functions.
431
432 ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
433 ;; headers there are.  If LEAVE-DELIM, don't delete the Unix mbox
434 ;; delimiter line.
435 (defun nnmbox-delete-mail (&optional force leave-delim)
436   ;; Delete the current X-Gnus-Newsgroup line.
437   ;; First delete record of active article, unless the article is being
438   ;; replaced, indicated by FORCE being non-nil.
439   (if (not force)
440       (nnmbox-record-deleted-article (nnmbox-article-group-number t)))
441   (or force
442       (gnus-delete-line))
443   ;; Beginning of the article.
444   (save-excursion
445     (save-restriction
446       (narrow-to-region
447        (prog2
448            (re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
449            (if leave-delim (progn (forward-line 1) (point))
450              (match-beginning 0))
451          (forward-line 1))
452        (or (and (re-search-forward (concat "^" message-unix-mail-delimiter)
453                                    nil t)
454                 (match-beginning 0))
455            (point-max)))
456       (goto-char (point-min))
457       ;; Only delete the article if no other group owns it as well.
458       (when (or force
459                 (not (re-search-forward "^X-Gnus-Newsgroup: " nil t))
460                 (search-backward "\n\n" nil t))
461         (delete-region (point-min) (point-max))))))
462
463 (defun nnmbox-possibly-change-newsgroup (newsgroup &optional server)
464   (when (and server
465              (not (nnmbox-server-opened server)))
466     (nnmbox-open-server server))
467   (when (or (not nnmbox-mbox-buffer)
468             (not (buffer-name nnmbox-mbox-buffer)))
469     (nnmbox-read-mbox))
470   (when (not nnmbox-group-alist)
471     (nnmail-activate 'nnmbox))
472   (if newsgroup
473       (when (assoc newsgroup nnmbox-group-alist)
474         (setq nnmbox-current-group newsgroup))
475     t))
476
477 (defun nnmbox-article-string (article)
478   (if (numberp article)
479       (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"
480               (int-to-string article) " ")
481     (concat "\nMessage-ID: " article)))
482
483 (defun nnmbox-article-group-number (this-line)
484   (save-excursion
485     (if this-line
486         (beginning-of-line)
487       (goto-char (point-min)))
488     (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
489                              nil t)
490       (cons (buffer-substring (match-beginning 1) (match-end 1))
491             (string-to-number
492              (buffer-substring (match-beginning 2) (match-end 2)))))))
493
494 (defun nnmbox-in-header-p (pos)
495   "Return non-nil if POS is in the header of an article."
496   (save-excursion
497     (goto-char pos)
498     (re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
499     (search-forward "\n\n" nil t)
500     (< pos (point))))
501
502 (defun nnmbox-find-article (article)
503   "Leaves point on the relevant X-Gnus-Newsgroup line if found."
504   ;; Check that article is in the active range first, to avoid an
505   ;; expensive exhaustive search if it isn't.
506   (if (and (numberp article)
507            (not (nnmbox-is-article-active-p article)))
508       nil
509     (let ((art-string (nnmbox-article-string article))
510           (found nil))
511       ;; There is the possibility that the X-Gnus-Newsgroup line appears
512       ;; in the body of an article (for instance, if an article has been
513       ;; forwarded from someone using Gnus as their mailer), so check
514       ;; that the line is actually part of the article header.
515       (or (and (search-forward art-string nil t)
516                (nnmbox-in-header-p (point)))
517           (progn
518             (goto-char (point-min))
519             (while (and (not found)
520                         (search-forward art-string nil t))
521               (setq found (nnmbox-in-header-p (point))))
522             found)))))
523
524 (defun nnmbox-record-active-article (group-art)
525   (let* ((group (car group-art))
526          (article (cdr group-art))
527          (entry
528           (or (assoc group nnmbox-group-active-articles)
529               (progn
530                 (push (list group)
531                       nnmbox-group-active-articles)
532                 (car nnmbox-group-active-articles)))))
533     ;; add article to index, either by building complete list
534     ;; in reverse order, or as a list of ranges.
535     (if (not nnmbox-group-building-active-articles)
536         (setcdr entry (gnus-add-to-range (cdr entry) (list article)))
537       (when (memq article (cdr entry))
538         (switch-to-buffer nnmbox-mbox-buffer)
539         (error "Article %s:%d already exists!" group article))
540       (when (and (cadr entry) (< article (cadr entry)))
541         (switch-to-buffer nnmbox-mbox-buffer)
542         (error "Article %s:%d out of order" group article))
543       (setcdr entry (cons article (cdr entry))))))
544
545 (defun nnmbox-record-deleted-article (group-art)
546   (let* ((group (car group-art))
547          (article (cdr group-art))
548          (entry
549           (or (assoc group nnmbox-group-active-articles)
550               (progn
551                 (push (list group)
552                       nnmbox-group-active-articles)
553                 (car nnmbox-group-active-articles)))))
554     ;; remove article from index
555     (setcdr entry (gnus-remove-from-range (cdr entry) (list article)))))
556
557 (defun nnmbox-is-article-active-p (article)
558   (gnus-member-of-range
559    article
560    (cdr (assoc nnmbox-current-group
561                nnmbox-group-active-articles))))
562
563 (defun nnmbox-save-mail (group-art)
564   "Called narrowed to an article."
565   (let ((delim (concat "^" message-unix-mail-delimiter)))
566     (goto-char (point-min))
567     ;; This might come from somewhere else.
568     (if (looking-at delim)
569         (forward-line 1)
570       (insert "From nobody " (current-time-string) "\n"))
571     ;; Quote all "From " lines in the article.
572     (while (re-search-forward delim nil t)
573       (goto-char (match-beginning 0))
574       (insert ">")))
575   (goto-char (point-max))
576   (unless (bolp)
577     (insert "\n"))
578   (nnmail-insert-lines)
579   (nnmail-insert-xref group-art)
580   (nnmbox-insert-newsgroup-line group-art)
581   (let ((alist group-art))
582     (while alist
583       (nnmbox-record-active-article (car alist))
584       (setq alist (cdr alist))))
585   (run-hooks 'nnmail-prepare-save-mail-hook)
586   (run-hooks 'nnmbox-prepare-save-mail-hook)
587   group-art)
588
589 (defun nnmbox-insert-newsgroup-line (group-art)
590   (save-excursion
591     (goto-char (point-min))
592     (when (search-forward "\n\n" nil t)
593       (forward-char -1)
594       (while group-art
595         (insert (format "X-Gnus-Newsgroup: %s:%d   %s\n"
596                         (caar group-art) (cdar group-art)
597                         (current-time-string)))
598         (setq group-art (cdr group-art))))
599     t))
600
601 (defun nnmbox-active-number (group)
602   ;; Find the next article number in GROUP.
603   (let ((active (cadr (assoc group nnmbox-group-alist))))
604     (if active
605         (setcdr active (1+ (cdr active)))
606       ;; This group is new, so we create a new entry for it.
607       ;; This might be a bit naughty... creating groups on the drop of
608       ;; a hat, but I don't know...
609       (push (list group (setq active (cons 1 1)))
610             nnmbox-group-alist))
611     (cdr active)))
612
613 (defun nnmbox-create-mbox ()
614   (when (not (file-exists-p nnmbox-mbox-file))
615     (let ((nnmail-file-coding-system
616            (or nnmbox-file-coding-system-for-write
617                nnmbox-file-coding-system))
618           (dir (file-name-directory nnmbox-mbox-file)))
619       (and dir (gnus-make-directory dir))
620       (nnmail-write-region (point-min) (point-min)
621                            nnmbox-mbox-file t 'nomesg))))
622
623 (defun nnmbox-read-mbox ()
624   (nnmail-activate 'nnmbox)
625   (nnmbox-create-mbox)
626   (if (and nnmbox-mbox-buffer
627            (buffer-name nnmbox-mbox-buffer)
628            (with-current-buffer nnmbox-mbox-buffer
629              (= (buffer-size) (nnheader-file-size nnmbox-mbox-file))))
630       ()
631     (save-excursion
632       (let ((delim (concat "^" message-unix-mail-delimiter))
633             (alist nnmbox-group-alist)
634             (nnmbox-group-building-active-articles t)
635             start end end-header number)
636         (set-buffer (setq nnmbox-mbox-buffer
637                           (let ((nnheader-file-coding-system
638                                  nnmbox-file-coding-system))
639                             (nnheader-find-file-noselect
640                              nnmbox-mbox-file t t))))
641         (mm-enable-multibyte)
642         (buffer-disable-undo)
643         (gnus-add-buffer)
644
645         ;; Go through the group alist and compare against the mbox file.
646         (while alist
647           (goto-char (point-max))
648           (when (and (re-search-backward
649                       (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) "
650                               (caar alist)) nil t)
651                      (> (setq number
652                               (string-to-number
653                                (buffer-substring
654                                 (match-beginning 1) (match-end 1))))
655                         (cdadar alist)))
656             (setcdr (cadar alist) number))
657           (setq alist (cdr alist)))
658
659         ;; Examine all articles for our private X-Gnus-Newsgroup
660         ;; headers.  This is done primarily as a consistency check, but
661         ;; it is convenient for building an index of the articles
662         ;; present, to avoid costly searches for missing articles
663         ;; (eg. when expiring articles).
664         (goto-char (point-min))
665         (setq nnmbox-group-active-articles nil)
666         (while (re-search-forward delim nil t)
667           (setq start (match-beginning 0))
668           (save-excursion
669             (search-forward "\n\n" nil t)
670             (setq end-header (point))
671             (setq end (or (and
672                            (re-search-forward delim nil t)
673                            (match-beginning 0))
674                           (point-max))))
675           (if (search-forward "\nX-Gnus-Newsgroup: " end-header t)
676               ;; Build a list of articles in each group, remembering
677               ;; that each article may be in more than one group.
678               (progn
679                 (nnmbox-record-active-article (nnmbox-article-group-number t))
680                 (while (search-forward "\nX-Gnus-Newsgroup: " end-header t)
681                   (nnmbox-record-active-article (nnmbox-article-group-number t))))
682             ;; The article is either new, or for some other reason
683             ;; hasn't got our private headers, so add them now.  The
684             ;; only situation I've encountered when the X-Gnus-Newsgroup
685             ;; header is missing is if the article contains a forwarded
686             ;; message which does contain that header line (earlier
687             ;; versions of Gnus didn't restrict their search to the
688             ;; headers).  In this case, there is an Xref line which
689             ;; provides the relevant information to construct the
690             ;; missing header(s).
691             (save-excursion
692               (save-restriction
693                 (narrow-to-region start end)
694                 (if (re-search-forward "\nXref: [^ ]+" end-header t)
695                     ;; generate headers from Xref:
696                     (let (alist)
697                       (while (re-search-forward " \\([^:]+\\):\\([0-9]+\\)" end-header t)
698                         (push (cons (match-string 1)
699                                     (string-to-number (match-string 2))) alist))
700                       (nnmbox-insert-newsgroup-line alist))
701                   ;; this is really a new article
702                   (nnmbox-save-mail
703                    (nnmail-article-group 'nnmbox-active-number))))))
704           (goto-char end))
705         ;; put article lists in order
706         (setq alist nnmbox-group-active-articles)
707         (while alist
708           (setcdr (car alist) (gnus-compress-sequence (nreverse (cdar alist))))
709           (setq alist (cdr alist)))))))
710
711 (provide 'nnmbox)
712
713 ;;; nnmbox.el ends here