29b35fdd8e7e39689929550c09ee9ead06080a59
[gnus] / lisp / nnbabyl.el
1 ;;; nnbabyl.el --- rmail mbox access for Gnus
2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
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 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18 ;; GNU General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING.  If not, write to
22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
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 'rmail)
33 (require 'nnmail)
34
35 (defvar nnbabyl-mbox-file (expand-file-name "~/RMAIL")
36   "The name of the rmail box file in the users home directory.")
37
38 (defvar nnbabyl-active-file (expand-file-name "~/.rmail-active")
39   "The name of the active file for the rmail box.")
40
41 (defvar nnbabyl-get-new-mail t
42   "If non-nil, nnbabyl will check the incoming mail file and split the mail.")
43
44 (defvar nnbabyl-prepare-save-mail-hook nil
45   "Hook run narrowed to an article before saving.")
46
47 \f
48
49 (defvar nnbabyl-mail-delimiter "\^_")
50
51 (defconst nnbabyl-version "nnbabyl 1.0"
52   "nnbabyl version.")
53
54 (defvar nnbabyl-mbox-buffer nil)
55 (defvar nnbabyl-current-group nil)
56 (defvar nnbabyl-status-string "")
57 (defvar nnbabyl-group-alist nil)
58 (defvar nnbabyl-active-timestamp nil)
59
60 \f
61
62 (defvar nnbabyl-current-server nil)
63 (defvar nnbabyl-server-alist nil)
64 (defvar nnbabyl-server-variables 
65   (list
66    (list 'nnbabyl-mbox-file nnbabyl-mbox-file)
67    (list 'nnbabyl-active-file nnbabyl-active-file)
68    (list 'nnbabyl-get-new-mail nnbabyl-get-new-mail)
69    '(nnbabyl-current-group nil)
70    '(nnbabyl-status-string "")
71    '(nnbabyl-group-alist nil)))
72
73 \f
74
75 ;;; Interface functions
76
77 (defun nnbabyl-retrieve-headers (sequence &optional newsgroup server fetch-old)
78   (save-excursion
79     (set-buffer nntp-server-buffer)
80     (erase-buffer)
81     (let ((number (length sequence))
82           (count 0)
83           article art-string start stop)
84       (nnbabyl-possibly-change-newsgroup newsgroup)
85       (while sequence
86         (setq article (car sequence))
87         (setq art-string (nnbabyl-article-string article))
88         (set-buffer nnbabyl-mbox-buffer)
89         (if (or (search-forward art-string nil t)
90                 (search-backward art-string nil t))
91             (progn
92               (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
93               (while (and (not (looking-at ".+:"))
94                           (zerop (forward-line 1))))
95               (setq start (point))
96               (search-forward "\n\n" nil t)
97               (setq stop (1- (point)))
98               (set-buffer nntp-server-buffer)
99               (insert "221 " (int-to-string article) " Article retrieved.\n")
100               (insert-buffer-substring nnbabyl-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              gnus-verbose-backends
109              (message "nnbabyl: Receiving headers... %d%%"
110                       (/ (* count 100) number))))
111
112       (and (numberp nnmail-large-newsgroup)
113            (> number nnmail-large-newsgroup)
114            gnus-verbose-backends
115            (message "nnbabyl: Receiving headers...done"))
116
117       ;; Fold continuation lines.
118       (set-buffer nntp-server-buffer)
119       (goto-char (point-min))
120       (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
121         (replace-match " " t t))
122       'headers)))
123
124 (defun nnbabyl-open-server (server &optional defs)
125   (nnheader-init-server-buffer)
126   (if (equal server nnbabyl-current-server)
127       t
128     (if nnbabyl-current-server
129         (setq nnbabyl-server-alist 
130               (cons (list nnbabyl-current-server
131                           (nnheader-save-variables nnbabyl-server-variables))
132                     nnbabyl-server-alist)))
133     (let ((state (assoc server nnbabyl-server-alist)))
134       (if state 
135           (progn
136             (nnheader-restore-variables (nth 1 state))
137             (setq nnbabyl-server-alist (delq state nnbabyl-server-alist)))
138         (nnheader-set-init-variables nnbabyl-server-variables defs)))
139     (setq nnbabyl-current-server server)))
140
141 (defun nnbabyl-close-server (&optional server)
142   (setq nnbabyl-current-server nil)
143   t)
144
145 (defun nnbabyl-server-opened (&optional server)
146   (and (equal server nnbabyl-current-server)
147        nnbabyl-mbox-buffer
148        (buffer-name nnbabyl-mbox-buffer)
149        nntp-server-buffer
150        (buffer-name nntp-server-buffer)))
151
152 (defun nnbabyl-status-message (&optional server)
153   nnbabyl-status-string)
154
155 (defun nnbabyl-request-article (article &optional newsgroup server buffer)
156   (nnbabyl-possibly-change-newsgroup newsgroup)
157   (save-excursion
158     (set-buffer nnbabyl-mbox-buffer)
159     (goto-char (point-min))
160     (if (search-forward (nnbabyl-article-string article) nil t)
161         (let (start stop summary-line)
162           (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
163           (while (and (not (looking-at ".+:"))
164                       (zerop (forward-line 1))))
165           (setq start (point))
166           (or (and (re-search-forward 
167                     (concat "^" nnbabyl-mail-delimiter) nil t)
168                    (forward-line -1))
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 (defun nnbabyl-request-group (group &optional server dont-check)
194   (save-excursion
195     (if (nnbabyl-possibly-change-newsgroup group)
196         (if dont-check
197             t
198           (save-excursion
199             (set-buffer nntp-server-buffer)
200             (erase-buffer)
201             (let ((active (assoc group nnbabyl-group-alist)))
202               (insert (format "211 %d %d %d %s\n" 
203                               (1+ (- (cdr (car (cdr active)))
204                                      (car (car (cdr active)))))
205                               (car (car (cdr active)))
206                               (cdr (car (cdr active)))
207                               (car active))))
208             t)))))
209
210 (defun nnbabyl-request-scan (&optional group server)
211   (nnbabyl-read-mbox)
212   (nnmail-get-new-mail 
213    'nnbabyl 
214    (lambda ()
215      (save-excursion
216        (set-buffer nnbabyl-mbox-buffer)
217        (save-buffer)))
218    nnbabyl-mbox-file 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
231 (defun nnbabyl-close-group (group &optional server)
232   t)
233
234 (defun nnbabyl-request-create-group (group &optional server) 
235   (nnmail-activate 'nnbabyl)
236   (or (assoc group nnbabyl-group-alist)
237       (let (active)
238         (setq nnbabyl-group-alist (cons (list group (setq active (cons 1 0)))
239                                         nnbabyl-group-alist))
240         (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)))
241   t)
242
243 (defun nnbabyl-request-list (&optional server)
244   (save-excursion
245     (or (nnmail-find-file nnbabyl-active-file)
246         (progn
247           (setq nnbabyl-group-alist (nnmail-get-active))
248           (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
249           (nnmail-find-file nnbabyl-active-file)))))
250
251 (defun nnbabyl-request-newgroups (date &optional server)
252   (nnbabyl-request-list server))
253
254 (defun nnbabyl-request-list-newsgroups (&optional server)
255   (setq nnbabyl-status-string "nnbabyl: LIST NEWSGROUPS is not implemented.")
256   nil)
257
258 (defun nnbabyl-request-post (&optional server)
259   (mail-send-and-exit nil))
260
261 (defun nnbabyl-request-expire-articles
262   (articles newsgroup &optional server force)
263   (nnbabyl-possibly-change-newsgroup newsgroup)
264   (let* ((days (or (and nnmail-expiry-wait-function
265                         (funcall nnmail-expiry-wait-function newsgroup))
266                    nnmail-expiry-wait))
267          (is-old t)
268          rest)
269     (nnmail-activate 'nnbabyl)
270
271     (save-excursion 
272       (set-buffer nnbabyl-mbox-buffer)
273       (set-text-properties (point-min) (point-max) nil)
274       (while (and articles is-old)
275         (goto-char (point-min))
276         (if (search-forward (nnbabyl-article-string (car articles)) nil t)
277             (if (or force
278                     (setq is-old
279                           (> (nnmail-days-between 
280                               (current-time-string)
281                               (buffer-substring 
282                                (point) (progn (end-of-line) (point))))
283                              days)))
284                 (progn
285                   (and gnus-verbose-backends
286                        (message "Deleting article %d in %s..." 
287                                 (car articles) newsgroup))
288                   (nnbabyl-delete-mail))
289               (setq rest (cons (car articles) rest))))
290         (setq articles (cdr articles)))
291       (save-buffer)
292       ;; Find the lowest active article in this group.
293       (let ((active (nth 1 (assoc newsgroup nnbabyl-group-alist))))
294         (goto-char (point-min))
295         (while (and (not (search-forward
296                           (nnbabyl-article-string (car active)) nil t))
297                     (<= (car active) (cdr active)))
298           (setcar active (1+ (car active)))
299           (goto-char (point-min))))
300       (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
301       (nconc rest articles))))
302
303 (defun nnbabyl-request-move-article 
304   (article group server accept-form &optional last)
305   (nnbabyl-possibly-change-newsgroup group)
306   (let ((buf (get-buffer-create " *nnbabyl move*"))
307         result)
308     (and 
309      (nnbabyl-request-article article group server)
310      (save-excursion
311        (set-buffer buf)
312        (insert-buffer-substring nntp-server-buffer)
313        (goto-char (point-min))
314        (if (re-search-forward 
315             "^X-Gnus-Newsgroup:" 
316             (save-excursion (search-forward "\n\n" nil t) (point)) t)
317            (delete-region (progn (beginning-of-line) (point))
318                           (progn (forward-line 1) (point))))
319        (setq result (eval accept-form))
320        (kill-buffer (current-buffer))
321        result)
322      (save-excursion
323        (set-buffer nnbabyl-mbox-buffer)
324        (goto-char (point-min))
325        (if (search-forward (nnbabyl-article-string article) nil t)
326            (nnbabyl-delete-mail))
327        (and last (save-buffer))))
328     result))
329
330 (defun nnbabyl-request-accept-article (group &optional last)
331   (let ((buf (current-buffer))
332         result beg)
333     (and 
334      (nnmail-activate 'nnbabyl)
335      (save-excursion
336        (goto-char (point-min))
337        (search-forward "\n\n" nil t)
338        (forward-line -1)
339        (save-excursion
340          (while (re-search-backward "^X-Gnus-Newsgroup: " beg t)
341            (delete-region (point) (progn (forward-line 1) (point)))))
342        (let ((nnmail-split-methods
343               (if (stringp group) (list (list group "")) 
344                 nnmail-split-methods)))
345          (setq result (car (nnbabyl-save-mail))))
346        (set-buffer nnbabyl-mbox-buffer)
347        (goto-char (point-max))
348        (search-backward "\n\^_")
349        (goto-char (match-end 0))
350        (insert-buffer-substring buf)
351        (and last (progn 
352                    (save-buffer)
353                    (nnmail-save-active
354                     nnbabyl-group-alist nnbabyl-active-file)))
355        result))))
356
357 (defun nnbabyl-request-replace-article (article group buffer)
358   (nnbabyl-possibly-change-newsgroup group)
359   (save-excursion
360     (set-buffer nnbabyl-mbox-buffer)
361     (goto-char (point-min))
362     (if (not (search-forward (nnbabyl-article-string article) nil t))
363         nil
364       (nnbabyl-delete-mail t t)
365       (insert-buffer-substring buffer)
366       (save-buffer)
367       t)))
368
369 (defun nnbabyl-request-delete-group (group &optional force server)
370   (nnbabyl-possibly-change-newsgroup group)
371   ;; Delete all articles in GROUP.
372   (if (not force)
373       ()                                ; Don't delete the articles.
374     (save-excursion
375       (set-buffer nnbabyl-mbox-buffer)
376       (goto-char (point-min))
377       ;; Delete all articles in this group.
378       (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"))
379             found)
380         (while (search-forward ident nil t)
381           (setq found t)
382           (nnbabyl-delete-mail))
383         (and found (save-buffer)))))
384   ;; Remove the group from all structures.
385   (setq nnbabyl-group-alist 
386         (delq (assoc group nnbabyl-group-alist) nnbabyl-group-alist)
387         nnbabyl-current-group nil)
388   ;; Save the active file.
389   (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
390   t)
391
392 (defun nnbabyl-request-rename-group (group new-name &optional server)
393   (nnbabyl-possibly-change-newsgroup group)
394   (save-excursion
395     (set-buffer nnbabyl-mbox-buffer)
396     (goto-char (point-min))
397     (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"))
398           (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":"))
399           found)
400       (while (search-forward ident nil t)
401         (replace-match new-ident t t)
402         (setq found t))
403       (and found (save-buffer))))
404   (let ((entry (assoc group nnbabyl-group-alist)))
405     (and entry (setcar entry new-name))
406     (setq nnbabyl-current-group nil)
407     ;; Save the new group alist.
408     (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
409     t))
410
411 \f
412 ;;; Internal functions.
413
414 ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
415 ;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox
416 ;; delimeter line.
417 (defun nnbabyl-delete-mail (&optional force leave-delim)
418   ;; Delete the current X-Gnus-Newsgroup line.
419   (or force
420       (delete-region
421        (progn (beginning-of-line) (point))
422        (progn (forward-line 1) (point))))
423   ;; Beginning of the article.
424   (save-excursion
425     (save-restriction
426       (widen)
427       (narrow-to-region
428        (save-excursion
429          (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
430          (if leave-delim (progn (forward-line 1) (point))
431            (match-beginning 0)))
432        (progn
433          (forward-line 1)
434          (or (and (re-search-forward (concat "^" nnbabyl-mail-delimiter) 
435                                      nil t)
436                   (if (and (not (bobp)) leave-delim)
437                       (progn (forward-line -2) (point))
438                     (match-beginning 0)))
439              (point-max))))
440       (goto-char (point-min))
441       ;; Only delete the article if no other groups owns it as well.
442       (if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
443           (delete-region (point-min) (point-max))))))
444
445 (defun nnbabyl-possibly-change-newsgroup (newsgroup)
446   (if (or (not nnbabyl-mbox-buffer)
447           (not (buffer-name nnbabyl-mbox-buffer)))
448       (save-excursion (nnbabyl-read-mbox)))
449   (or nnbabyl-group-alist
450       (nnmail-activate 'nnbabyl))
451   (if newsgroup
452       (if (assoc newsgroup nnbabyl-group-alist)
453           (setq nnbabyl-current-group newsgroup)
454         (setq nnbabyl-status-string "No such group in file")
455         nil)))
456
457 (defun nnbabyl-article-string (article)
458   (if (numberp article)
459       (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":" 
460               (int-to-string article) " ")
461     (concat "\nMessage-ID: " article)))
462
463 (defun nnbabyl-article-group-number ()
464   (save-excursion
465     (goto-char (point-min))
466     (and (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
467                             nil t)
468          (cons (buffer-substring (match-beginning 1) (match-end 1))
469                (string-to-int
470                 (buffer-substring (match-beginning 2) (match-end 2)))))))
471
472 (defun nnbabyl-insert-lines ()
473   "Insert how many lines and chars there are in the body of the mail."
474   (let (lines chars)
475     (save-excursion
476       (goto-char (point-min))
477       (if (search-forward "\n\n" nil t) 
478           (progn
479             ;; There may be an EOOH line here...
480             (if (looking-at "\\*\\*\\* EOOH \\*\\*\\*")
481                 (search-forward "\n\n" nil t))
482             (setq chars (- (point-max) (point)))
483             (setq lines (- (count-lines (point) (point-max)) 1))
484             ;; Move back to the end of the headers. 
485             (goto-char (point-min))
486             (search-forward "\n\n" nil t)
487             (forward-char -1)
488             (save-excursion
489               (if (re-search-backward "^Lines: " nil t)
490                   (delete-region (point) (progn (forward-line 1) (point)))))
491             (insert (format "Lines: %d\n" lines))
492             chars)))))
493
494 (defun nnbabyl-save-mail ()
495   ;; Called narrowed to an article.
496   (let ((group-art (nreverse (nnmail-article-group 'nnbabyl-active-number))))
497     (nnbabyl-insert-lines)
498     (nnmail-insert-xref group-art)
499     (nnbabyl-insert-newsgroup-line group-art)
500     (run-hooks 'nnbabyl-prepare-save-mail-hook)
501     group-art))
502
503 (defun nnbabyl-insert-newsgroup-line (group-art)
504   (save-excursion
505     (goto-char (point-min))
506     (while (looking-at "From ")
507       (replace-match "Mail-from: From " t t)
508       (forward-line 1))
509     ;; If there is a C-l at the beginning of the narrowed region, this
510     ;; isn't really a "save", but rather a "scan".
511     (goto-char (point-min))
512     (or (looking-at "\^L")
513         (save-excursion
514           (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
515           (goto-char (point-max))
516           (insert "\^_\n")))
517     (if (search-forward "\n\n" nil t)
518         (progn
519           (forward-char -1)
520           (while group-art
521             (insert (format "X-Gnus-Newsgroup: %s:%d   %s\n" 
522                             (car (car group-art)) (cdr (car group-art))
523                             (current-time-string)))
524             (setq group-art (cdr group-art)))))
525     t))
526
527 (defun nnbabyl-active-number (group)
528   ;; Find the next article number in GROUP.
529   (let ((active (car (cdr (assoc group nnbabyl-group-alist)))))
530     (if active
531         (setcdr active (1+ (cdr active)))
532       ;; This group is new, so we create a new entry for it.
533       ;; This might be a bit naughty... creating groups on the drop of
534       ;; a hat, but I don't know...
535       (setq nnbabyl-group-alist (cons (list group (setq active (cons 1 1)))
536                                       nnbabyl-group-alist)))
537     (cdr active)))
538
539 (defun nnbabyl-read-mbox ()
540   (nnmail-activate 'nnbabyl)
541   (or (file-exists-p nnbabyl-mbox-file)
542       (save-excursion
543         (set-buffer (setq nnbabyl-mbox-buffer
544                           (create-file-buffer nnbabyl-mbox-file)))
545         (setq buffer-file-name nnbabyl-mbox-file)
546         (insert "BABYL OPTIONS:\n\n\^_")
547         (write-region (point-min) (point-max) nnbabyl-mbox-file t 'nomesg)))
548
549   (if (and nnbabyl-mbox-buffer
550            (buffer-name nnbabyl-mbox-buffer)
551            (save-excursion
552              (set-buffer nnbabyl-mbox-buffer)
553              (= (buffer-size) (nth 7 (file-attributes nnbabyl-mbox-file)))))
554       ()
555     (save-excursion
556       (let ((delim (concat "^" nnbabyl-mail-delimiter))
557             start end)
558         (set-buffer (setq nnbabyl-mbox-buffer 
559                           (nnheader-find-file-noselect 
560                            nnbabyl-mbox-file nil 'raw)))
561         (buffer-disable-undo (current-buffer))
562         (widen)
563         (setq buffer-read-only nil)
564         (fundamental-mode)
565         
566         (goto-char (point-min))
567         (re-search-forward delim nil t)
568         (setq start (match-end 0))
569         (while (re-search-forward delim nil t)
570           (setq end (match-end 0))
571           (or (search-backward "\nX-Gnus-Newsgroup: " start t)
572               (progn
573                 (goto-char end)
574                 (save-excursion
575                   (save-restriction
576                     (goto-char start)
577                     (narrow-to-region start end)
578                     (nnbabyl-save-mail)
579                     (setq end (point-max))))))
580           (goto-char (setq start end)))
581         (and (buffer-modified-p (current-buffer)) (save-buffer))
582         (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)))))
583
584 (defun nnbabyl-remove-incoming-delims ()
585   (goto-char (point-min))
586   (while (search-forward "\^_" nil t)
587     (replace-match "?" t t)))
588
589 (provide 'nnbabyl)
590
591 ;;; nnbabyl.el ends here