1;;; nnbabyl.el --- rmail mbox access for Gnus
2
3;; Copyright (C) 1995, 1996, 1997, 1998, 1099, 2000, 2001, 2002, 2003,
4;;   2004, 2005, 2006, 2007 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;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs; see the file COPYING.  If not, write to the
24;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
25;; Boston, MA 02110-1301, USA.
26
27;;; Commentary:
28
29;; For an overview of what the interface functions do, please see the
30;; Gnus sources.
31
32;;; Code:
33
34(require 'nnheader)
35(condition-case nil
36    (require 'rmail)
37  (t (nnheader-message
38      5 "Ignore rmail errors from this file, you don't have rmail")))
39(require 'nnmail)
40(require 'nnoo)
41(eval-when-compile (require 'cl))
42
43(nnoo-declare nnbabyl)
44
45(defvoo nnbabyl-mbox-file (expand-file-name "~/RMAIL")
46  "The name of the rmail box file in the users home directory.")
47
48(defvoo nnbabyl-active-file (expand-file-name "~/.rmail-active")
49  "The name of the active file for the rmail box.")
50
51(defvoo nnbabyl-get-new-mail t
52  "If non-nil, nnbabyl will check the incoming mail file and split the mail.")
53
54
55(defvoo nnbabyl-prepare-save-mail-hook nil
56  "Hook run narrowed to an article before saving.")
57
58
59
60(defvar nnbabyl-mail-delimiter "\^_")
61
62(defconst nnbabyl-version "nnbabyl 1.0"
63  "nnbabyl version.")
64
65(defvoo nnbabyl-mbox-buffer nil)
66(defvoo nnbabyl-current-group nil)
67(defvoo nnbabyl-status-string "")
68(defvoo nnbabyl-group-alist nil)
69(defvoo nnbabyl-active-timestamp nil)
70
71(defvoo nnbabyl-previous-buffer-mode nil)
72
73(eval-and-compile
74  (autoload 'gnus-set-text-properties "gnus-ems"))
75
76
77
78;;; Interface functions
79
80(nnoo-define-basics nnbabyl)
81
82(deffoo nnbabyl-retrieve-headers (articles &optional group server fetch-old)
83  (save-excursion
84    (set-buffer nntp-server-buffer)
85    (erase-buffer)
86    (let ((number (length articles))
87	  (count 0)
88	  (delim (concat "^" nnbabyl-mail-delimiter))
89	  article art-string start stop)
90      (nnbabyl-possibly-change-newsgroup group server)
91      (while (setq article (pop articles))
92	(setq art-string (nnbabyl-article-string article))
93	(set-buffer nnbabyl-mbox-buffer)
94	(end-of-line)
95	(when (or (search-forward art-string nil t)
96		  (search-backward art-string nil t))
97	  (unless (re-search-backward delim nil t)
98	    (goto-char (point-min)))
99	  (while (and (not (looking-at ".+:"))
100		      (zerop (forward-line 1))))
101	  (setq start (point))
102	  (search-forward "\n\n" nil t)
103	  (setq stop (1- (point)))
104	  (set-buffer nntp-server-buffer)
105	  (insert "221 ")
106	  (princ article (current-buffer))
107	  (insert " Article retrieved.\n")
108	  (insert-buffer-substring nnbabyl-mbox-buffer start stop)
109	  (goto-char (point-max))
110	  (insert ".\n"))
111	(and (numberp nnmail-large-newsgroup)
112	     (> number nnmail-large-newsgroup)
113	     (zerop (% (incf count) 20))
114	     (nnheader-message 5 "nnbabyl: Receiving headers... %d%%"
115			       (/ (* count 100) number))))
116
117      (and (numberp nnmail-large-newsgroup)
118	   (> number nnmail-large-newsgroup)
119	   (nnheader-message 5 "nnbabyl: Receiving headers...done"))
120
121      (set-buffer nntp-server-buffer)
122      (nnheader-fold-continuation-lines)
123      'headers)))
124
125(deffoo nnbabyl-open-server (server &optional defs)
126  (nnoo-change-server 'nnbabyl server defs)
127  (nnbabyl-create-mbox)
128  (cond
129   ((not (file-exists-p nnbabyl-mbox-file))
130    (nnbabyl-close-server)
131    (nnheader-report 'nnbabyl "No such file: %s" nnbabyl-mbox-file))
132   ((file-directory-p nnbabyl-mbox-file)
133    (nnbabyl-close-server)
134    (nnheader-report 'nnbabyl "Not a regular file: %s" nnbabyl-mbox-file))
135   (t
136    (nnheader-report 'nnbabyl "Opened server %s using mbox %s" server
137		     nnbabyl-mbox-file)
138    t)))
139
140(deffoo nnbabyl-close-server (&optional server)
141  ;; Restore buffer mode.
142  (when (and (nnbabyl-server-opened)
143	     nnbabyl-previous-buffer-mode)
144    (save-excursion
145      (set-buffer nnbabyl-mbox-buffer)
146      (narrow-to-region
147       (caar nnbabyl-previous-buffer-mode)
148       (cdar nnbabyl-previous-buffer-mode))
149      (funcall (cdr nnbabyl-previous-buffer-mode))))
150  (nnoo-close-server 'nnbabyl server)
151  (setq nnbabyl-mbox-buffer nil)
152  t)
153
154(deffoo nnbabyl-server-opened (&optional server)
155  (and (nnoo-current-server-p 'nnbabyl server)
156       nnbabyl-mbox-buffer
157       (buffer-name nnbabyl-mbox-buffer)
158       nntp-server-buffer
159       (buffer-name nntp-server-buffer)))
160
161(deffoo nnbabyl-request-article (article &optional newsgroup server buffer)
162  (nnbabyl-possibly-change-newsgroup newsgroup server)
163  (save-excursion
164    (set-buffer nnbabyl-mbox-buffer)
165    (goto-char (point-min))
166    (when (search-forward (nnbabyl-article-string article) nil t)
167      (let (start stop summary-line)
168	(unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
169	  (goto-char (point-min))
170	  (end-of-line))
171	(while (and (not (looking-at ".+:"))
172		    (zerop (forward-line 1))))
173	(setq start (point))
174	(or (when (re-search-forward
175		   (concat "^" nnbabyl-mail-delimiter) nil t)
176	      (beginning-of-line)
177	      t)
178	    (goto-char (point-max)))
179	(setq stop (point))
180	(let ((nntp-server-buffer (or buffer nntp-server-buffer)))
181	  (set-buffer nntp-server-buffer)
182	  (erase-buffer)
183	  (insert-buffer-substring nnbabyl-mbox-buffer start stop)
184	  (goto-char (point-min))
185	  ;; If there is an EOOH header, then we have to remove some
186	  ;; duplicated headers.
187	  (setq summary-line (looking-at "Summary-line:"))
188	  (when (search-forward "\n*** EOOH ***" nil t)
189	    (if summary-line
190		;; The headers to be deleted are located before the
191		;; EOOH line...
192		(delete-region (point-min) (progn (forward-line 1)
193						  (point)))
194	      ;; ...or after.
195	      (delete-region (progn (beginning-of-line) (point))
196			     (or (search-forward "\n\n" nil t)
197				 (point)))))
198	  (if (numberp article)
199	      (cons nnbabyl-current-group article)
200	    (nnbabyl-article-group-number)))))))
201
202(deffoo nnbabyl-request-group (group &optional server dont-check)
203  (let ((active (cadr (assoc group nnbabyl-group-alist))))
204    (save-excursion
205      (cond
206       ((or (null active)
207	    (null (nnbabyl-possibly-change-newsgroup group server)))
208	(nnheader-report 'nnbabyl "No such group: %s" group))
209       (dont-check
210	(nnheader-report 'nnbabyl "Selected group %s" group)
211	(nnheader-insert ""))
212       (t
213	(nnheader-report 'nnbabyl "Selected group %s" group)
214	(nnheader-insert "211 %d %d %d %s\n"
215			 (1+ (- (cdr active) (car active)))
216			 (car active) (cdr active) group))))))
217
218(deffoo nnbabyl-request-scan (&optional group server)
219  (nnbabyl-possibly-change-newsgroup group server)
220  (nnbabyl-read-mbox)
221  (nnmail-get-new-mail
222   'nnbabyl
223   (lambda ()
224     (save-excursion
225       (set-buffer nnbabyl-mbox-buffer)
226       (save-buffer)))
227   (file-name-directory nnbabyl-mbox-file)
228   group
229   (lambda ()
230     (save-excursion
231       (let ((in-buf (current-buffer)))
232	 (goto-char (point-min))
233	 (while (search-forward "\n\^_\n" nil t)
234	   (delete-char -1))
235	 (set-buffer nnbabyl-mbox-buffer)
236	 (goto-char (point-max))
237	 (search-backward "\n\^_" nil t)
238	 (goto-char (match-end 0))
239	 (insert-buffer-substring in-buf)))
240     (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))))
241
242(deffoo nnbabyl-close-group (group &optional server)
243  t)
244
245(deffoo nnbabyl-request-create-group (group &optional server args)
246  (nnmail-activate 'nnbabyl)
247  (unless (assoc group nnbabyl-group-alist)
248    (push (list group (cons 1 0))
249	  nnbabyl-group-alist)
250    (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))
251  t)
252
253(deffoo nnbabyl-request-list (&optional server)
254  (save-excursion
255    (nnmail-find-file nnbabyl-active-file)
256    (setq nnbabyl-group-alist (nnmail-get-active))
257    t))
258
259(deffoo nnbabyl-request-newgroups (date &optional server)
260  (nnbabyl-request-list server))
261
262(deffoo nnbabyl-request-list-newsgroups (&optional server)
263  (nnheader-report 'nnbabyl "nnbabyl: LIST NEWSGROUPS is not implemented."))
264
265(deffoo nnbabyl-request-expire-articles
266    (articles newsgroup &optional server force)
267  (nnbabyl-possibly-change-newsgroup newsgroup server)
268  (let* ((is-old t)
269	 rest)
270    (nnmail-activate 'nnbabyl)
271
272    (save-excursion
273      (set-buffer nnbabyl-mbox-buffer)
274      (gnus-set-text-properties (point-min) (point-max) nil)
275      (while (and articles is-old)
276	(goto-char (point-min))
277	(when (search-forward (nnbabyl-article-string (car articles)) nil t)
278	  (if (setq is-old
279		    (nnmail-expired-article-p
280		     newsgroup
281		     (buffer-substring
282		      (point) (progn (end-of-line) (point))) force))
283	      (progn
284		(unless (eq nnmail-expiry-target 'delete)
285		  (with-temp-buffer
286		    (nnbabyl-request-article (car articles)
287					     newsgroup server
288					     (current-buffer))
289		    (let ((nnml-current-directory nil))
290		      (nnmail-expiry-target-group
291		       nnmail-expiry-target newsgroup)))
292		  (nnbabyl-possibly-change-newsgroup newsgroup server))
293		(nnheader-message 5 "Deleting article %d in %s..."
294				  (car articles) newsgroup)
295		(nnbabyl-delete-mail))
296	    (push (car articles) rest)))
297	(setq articles (cdr articles)))
298      (save-buffer)
299      ;; Find the lowest active article in this group.
300      (let ((active (nth 1 (assoc newsgroup nnbabyl-group-alist))))
301	(goto-char (point-min))
302	(while (and (not (search-forward
303			  (nnbabyl-article-string (car active)) nil t))
304		    (<= (car active) (cdr active)))
305	  (setcar active (1+ (car active)))
306	  (goto-char (point-min))))
307      (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
308      (nconc rest articles))))
309
310(deffoo nnbabyl-request-move-article
311    (article group server accept-form &optional last)
312  (let ((buf (get-buffer-create " *nnbabyl move*"))
313	result)
314    (and
315     (nnbabyl-request-article article group server)
316     (save-excursion
317       (set-buffer buf)
318       (insert-buffer-substring nntp-server-buffer)
319       (goto-char (point-min))
320       (while (re-search-forward
321	       "^X-Gnus-Newsgroup:"
322	       (save-excursion (search-forward "\n\n" nil t) (point)) t)
323	 (delete-region (progn (beginning-of-line) (point))
324			(progn (forward-line 1) (point))))
325       (setq result (eval accept-form))
326       (kill-buffer (current-buffer))
327       result)
328     (save-excursion
329       (nnbabyl-possibly-change-newsgroup group server)
330       (set-buffer nnbabyl-mbox-buffer)
331       (goto-char (point-min))
332       (if (search-forward (nnbabyl-article-string article) nil t)
333	   (nnbabyl-delete-mail))
334       (and last (save-buffer))))
335    result))
336
337(deffoo nnbabyl-request-accept-article (group &optional server last)
338  (nnbabyl-possibly-change-newsgroup group server)
339  (nnmail-check-syntax)
340  (let ((buf (current-buffer))
341	result beg)
342    (and
343     (nnmail-activate 'nnbabyl)
344     (save-excursion
345       (goto-char (point-min))
346       (search-forward "\n\n" nil t)
347       (forward-line -1)
348       (save-excursion
349	 (while (re-search-backward "^X-Gnus-Newsgroup: " beg t)
350	   (delete-region (point) (progn (forward-line 1) (point)))))
351       (when nnmail-cache-accepted-message-ids
352	 (nnmail-cache-insert (nnmail-fetch-field "message-id")
353			      group
354			      (nnmail-fetch-field "subject")
355			      (nnmail-fetch-field "from")))
356       (setq result
357	     (if (stringp group)
358		 (list (cons group (nnbabyl-active-number group)))
359	       (nnmail-article-group 'nnbabyl-active-number)))
360       (if (and (null result)
361		(yes-or-no-p "Moved to `junk' group; delete article? "))
362	   (setq result 'junk)
363	 (setq result (car (nnbabyl-save-mail result))))
364       (set-buffer nnbabyl-mbox-buffer)
365       (goto-char (point-max))
366       (search-backward "\n\^_")
367       (goto-char (match-end 0))
368       (insert-buffer-substring buf)
369       (when last
370	 (when nnmail-cache-accepted-message-ids
371	   (nnmail-cache-insert (nnmail-fetch-field "message-id")
372				group
373				(nnmail-fetch-field "subject")
374				(nnmail-fetch-field "from")))
375	 (save-buffer)
376	 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))
377       result))))
378
379(deffoo nnbabyl-request-replace-article (article group buffer)
380  (nnbabyl-possibly-change-newsgroup group)
381  (save-excursion
382    (set-buffer nnbabyl-mbox-buffer)
383    (goto-char (point-min))
384    (if (not (search-forward (nnbabyl-article-string article) nil t))
385	nil
386      (nnbabyl-delete-mail t t)
387      (insert-buffer-substring buffer)
388      (save-buffer)
389      t)))
390
391(deffoo nnbabyl-request-delete-group (group &optional force server)
392  (nnbabyl-possibly-change-newsgroup group server)
393  ;; Delete all articles in GROUP.
394  (if (not force)
395      ()				; Don't delete the articles.
396    (save-excursion
397      (set-buffer nnbabyl-mbox-buffer)
398      (goto-char (point-min))
399      ;; Delete all articles in this group.
400      (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"))
401	    found)
402	(while (search-forward ident nil t)
403	  (setq found t)
404	  (nnbabyl-delete-mail))
405	(when found
406	  (save-buffer)))))
407  ;; Remove the group from all structures.
408  (setq nnbabyl-group-alist
409	(delq (assoc group nnbabyl-group-alist) nnbabyl-group-alist)
410	nnbabyl-current-group nil)
411  ;; Save the active file.
412  (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
413  t)
414
415(deffoo nnbabyl-request-rename-group (group new-name &optional server)
416  (nnbabyl-possibly-change-newsgroup group server)
417  (save-excursion
418    (set-buffer nnbabyl-mbox-buffer)
419    (goto-char (point-min))
420    (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"))
421	  (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":"))
422	  found)
423      (while (search-forward ident nil t)
424	(replace-match new-ident t t)
425	(setq found t))
426      (when found
427	(save-buffer))))
428  (let ((entry (assoc group nnbabyl-group-alist)))
429    (and entry (setcar entry new-name))
430    (setq nnbabyl-current-group nil)
431    ;; Save the new group alist.
432    (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
433    t))
434
435
436;;; Internal functions.
437
438;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
439;; headers there are.  If LEAVE-DELIM, don't delete the Unix mbox
440;; delimiter line.
441(defun nnbabyl-delete-mail (&optional force leave-delim)
442  ;; Delete the current X-Gnus-Newsgroup line.
443  (unless force
444    (delete-region
445     (progn (beginning-of-line) (point))
446     (progn (forward-line 1) (point))))
447  ;; Beginning of the article.
448  (save-excursion
449    (save-restriction
450      (widen)
451      (narrow-to-region
452       (save-excursion
453	 (unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
454	   (goto-char (point-min))
455	   (end-of-line))
456	 (if leave-delim (progn (forward-line 1) (point))
457	   (match-beginning 0)))
458       (progn
459	 (forward-line 1)
460	 (or (and (re-search-forward (concat "^" nnbabyl-mail-delimiter)
461				     nil t)
462		  (match-beginning 0))
463	     (point-max))))
464      (goto-char (point-min))
465      ;; Only delete the article if no other groups owns it as well.
466      (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
467	(delete-region (point-min) (point-max))))))
468
469(defun nnbabyl-possibly-change-newsgroup (newsgroup &optional server)
470  (when (and server
471	     (not (nnbabyl-server-opened server)))
472    (nnbabyl-open-server server))
473  (when (or (not nnbabyl-mbox-buffer)
474	    (not (buffer-name nnbabyl-mbox-buffer)))
475    (save-excursion (nnbabyl-read-mbox)))
476  (unless nnbabyl-group-alist
477    (nnmail-activate 'nnbabyl))
478  (if newsgroup
479      (if (assoc newsgroup nnbabyl-group-alist)
480	  (setq nnbabyl-current-group newsgroup)
481	(nnheader-report 'nnbabyl "No such group in file"))
482    t))
483
484(defun nnbabyl-article-string (article)
485  (if (numberp article)
486      (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"
487	      (int-to-string article) " ")
488    (concat "\nMessage-ID: " article)))
489
490(defun nnbabyl-article-group-number ()
491  (save-excursion
492    (goto-char (point-min))
493    (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
494			     nil t)
495      (cons (buffer-substring (match-beginning 1) (match-end 1))
496	    (string-to-number
497	     (buffer-substring (match-beginning 2) (match-end 2)))))))
498
499(defun nnbabyl-insert-lines ()
500  "Insert how many lines and chars there are in the body of the mail."
501  (let (lines chars)
502    (save-excursion
503      (goto-char (point-min))
504      (when (search-forward "\n\n" nil t)
505	;; There may be an EOOH line here...
506	(when (looking-at "\\*\\*\\* EOOH \\*\\*\\*")
507	  (search-forward "\n\n" nil t))
508	(setq chars (- (point-max) (point))
509	      lines (max (- (count-lines (point) (point-max)) 1) 0))
510	;; Move back to the end of the headers.
511	(goto-char (point-min))
512	(search-forward "\n\n" nil t)
513	(forward-char -1)
514	(save-excursion
515	  (when (re-search-backward "^Lines: " nil t)
516	    (delete-region (point) (progn (forward-line 1) (point)))))
517	(insert (format "Lines: %d\n" lines))
518	chars))))
519
520(defun nnbabyl-save-mail (group-art)
521  ;; Called narrowed to an article.
522  (nnbabyl-insert-lines)
523  (nnmail-insert-xref group-art)
524  (nnbabyl-insert-newsgroup-line group-art)
525  (run-hooks 'nnbabyl-prepare-save-mail-hook)
526  group-art)
527
528(defun nnbabyl-insert-newsgroup-line (group-art)
529  (save-excursion
530    (goto-char (point-min))
531    (while (looking-at "From ")
532      (replace-match "Mail-from: From " t t)
533      (forward-line 1))
534    ;; If there is a C-l at the beginning of the narrowed region, this
535    ;; isn't really a "save", but rather a "scan".
536    (goto-char (point-min))
537    (unless (looking-at "\^L")
538      (save-excursion
539	(insert "\^L\n0, unseen,,\n*** EOOH ***\n")
540	(goto-char (point-max))
541	(insert "\^_\n")))
542    (when (search-forward "\n\n" nil t)
543      (forward-char -1)
544      (while group-art
545	(insert (format "X-Gnus-Newsgroup: %s:%d   %s\n"
546			(caar group-art) (cdar group-art)
547			(current-time-string)))
548	(setq group-art (cdr group-art))))
549    t))
550
551(defun nnbabyl-active-number (group)
552  ;; Find the next article number in GROUP.
553  (let ((active (cadr (assoc group nnbabyl-group-alist))))
554    (if active
555	(setcdr active (1+ (cdr active)))
556      ;; This group is new, so we create a new entry for it.
557      ;; This might be a bit naughty... creating groups on the drop of
558      ;; a hat, but I don't know...
559      (push (list group (setq active (cons 1 1)))
560	    nnbabyl-group-alist))
561    (cdr active)))
562
563(defun nnbabyl-create-mbox ()
564  (unless (file-exists-p nnbabyl-mbox-file)
565    ;; Create a new, empty RMAIL mbox file.
566    (save-excursion
567      (set-buffer (setq nnbabyl-mbox-buffer
568			(create-file-buffer nnbabyl-mbox-file)))
569      (setq buffer-file-name nnbabyl-mbox-file)
570      (insert "BABYL OPTIONS:\n\n\^_")
571      (nnmail-write-region
572       (point-min) (point-max) nnbabyl-mbox-file t 'nomesg))))
573
574(defun nnbabyl-read-mbox ()
575  (nnmail-activate 'nnbabyl)
576  (nnbabyl-create-mbox)
577
578  (unless (and nnbabyl-mbox-buffer
579	       (buffer-name nnbabyl-mbox-buffer)
580	       (save-excursion
581		 (set-buffer nnbabyl-mbox-buffer)
582		 (= (buffer-size) (nnheader-file-size nnbabyl-mbox-file))))
583    ;; This buffer has changed since we read it last.  Possibly.
584    (save-excursion
585      (let ((delim (concat "^" nnbabyl-mail-delimiter))
586	    (alist nnbabyl-group-alist)
587	    start end number)
588	(set-buffer (setq nnbabyl-mbox-buffer
589			  (nnheader-find-file-noselect
590			   nnbabyl-mbox-file nil t)))
591	;; Save previous buffer mode.
592	(setq nnbabyl-previous-buffer-mode
593	      (cons (cons (point-min) (point-max))
594		    major-mode))
595
596	(buffer-disable-undo)
597	(widen)
598	(setq buffer-read-only nil)
599	(fundamental-mode)
600
601	;; Go through the group alist and compare against
602	;; the rmail file.
603	(while alist
604	  (goto-char (point-max))
605	  (when (and (re-search-backward
606		      (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) "
607			      (caar alist))
608		      nil t)
609		     (> (setq number
610			      (string-to-number
611			       (buffer-substring
612				(match-beginning 1) (match-end 1))))
613			(cdadar alist)))
614	    (setcdr (cadar alist) number))
615	  (setq alist (cdr alist)))
616
617	;; We go through the mbox and make sure that each and
618	;; every mail belongs to some group or other.
619	(goto-char (point-min))
620	(if (looking-at "\^L")
621	    (setq start (point))
622	  (re-search-forward delim nil t)
623	  (setq start (match-end 0)))
624	(while (re-search-forward delim nil t)
625	  (setq end (match-end 0))
626	  (unless (search-backward "\nX-Gnus-Newsgroup: " start t)
627	    (goto-char end)
628	    (save-excursion
629	      (save-restriction
630		(narrow-to-region (goto-char start) end)
631		(nnbabyl-save-mail
632		 (nnmail-article-group 'nnbabyl-active-number))
633		(setq end (point-max)))))
634	  (goto-char (setq start end)))
635	(when (buffer-modified-p (current-buffer))
636	  (save-buffer))
637	(nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)))))
638
639(defun nnbabyl-remove-incoming-delims ()
640  (goto-char (point-min))
641  (while (search-forward "\^_" nil t)
642    (replace-match "?" t t)))
643
644(defun nnbabyl-check-mbox ()
645  "Go through the nnbabyl mbox and make sure that no article numbers are reused."
646  (interactive)
647  (let ((idents (make-vector 1000 0))
648	id)
649    (save-excursion
650      (when (or (not nnbabyl-mbox-buffer)
651		(not (buffer-name nnbabyl-mbox-buffer)))
652	(nnbabyl-read-mbox))
653      (set-buffer nnbabyl-mbox-buffer)
654      (goto-char (point-min))
655      (while (re-search-forward "^X-Gnus-Newsgroup: \\([^ ]+\\) "  nil t)
656	(if (intern-soft (setq id (match-string 1)) idents)
657	    (progn
658	      (delete-region (progn (beginning-of-line) (point))
659			     (progn (forward-line 1) (point)))
660	      (nnheader-message 7 "Moving %s..." id)
661	      (nnbabyl-save-mail
662	       (nnmail-article-group 'nnbabyl-active-number)))
663	  (intern id idents)))
664      (when (buffer-modified-p (current-buffer))
665	(save-buffer))
666      (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
667      (nnheader-message 5 ""))))
668
669(provide 'nnbabyl)
670
671;;; arch-tag: aa7ddedb-8c07-4c0e-beb0-58e795c2b81b
672;;; nnbabyl.el ends here
673