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