*** empty log message ***
[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   t)
143
144 (defun nnbabyl-server-opened (&optional server)
145   (and (equal server nnbabyl-current-server)
146        nnbabyl-mbox-buffer
147        (buffer-name nnbabyl-mbox-buffer)
148        nntp-server-buffer
149        (buffer-name nntp-server-buffer)))
150
151 (defun nnbabyl-status-message (&optional server)
152   nnbabyl-status-string)
153
154 (defun nnbabyl-request-article (article &optional newsgroup server buffer)
155   (nnbabyl-possibly-change-newsgroup newsgroup)
156   (save-excursion
157     (set-buffer nnbabyl-mbox-buffer)
158     (goto-char (point-min))
159     (if (search-forward (nnbabyl-article-string article) nil t)
160         (let (start stop summary-line)
161           (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
162           (while (and (not (looking-at ".+:"))
163                       (zerop (forward-line 1))))
164           (setq start (point))
165           (or (and (re-search-forward 
166                     (concat "^" nnbabyl-mail-delimiter) nil t)
167                    (forward-line -1))
168               (goto-char (point-max)))
169           (setq stop (point))
170           (let ((nntp-server-buffer (or buffer nntp-server-buffer)))
171             (set-buffer nntp-server-buffer)
172             (erase-buffer)
173             (insert-buffer-substring nnbabyl-mbox-buffer start stop)
174             (goto-char (point-min))
175             ;; If there is an EOOH header, then we have to remove some
176             ;; duplicated headers. 
177             (setq summary-line (looking-at "Summary-line:"))
178             (when (search-forward "\n*** EOOH ***" nil t)
179               (if summary-line
180                   ;; The headers to be deleted are located before the
181                   ;; EOOH line...
182                   (delete-region (point-min) (progn (forward-line 1)
183                   (point)))
184                 ;; ...or after.
185                 (delete-region (progn (beginning-of-line) (point))
186                                (or (search-forward "\n\n" nil t)
187                                    (point)))))
188             (if (numberp article) 
189                 (cons nnbabyl-current-group article)
190               (nnbabyl-article-group-number)))))))
191
192 (defun nnbabyl-request-group (group &optional server dont-check)
193   (save-excursion
194     (if (nnbabyl-possibly-change-newsgroup group)
195         (if dont-check
196             t
197           (save-excursion
198             (set-buffer nntp-server-buffer)
199             (erase-buffer)
200             (let ((active (assoc group nnbabyl-group-alist)))
201               (insert (format "211 %d %d %d %s\n" 
202                               (1+ (- (cdr (car (cdr active)))
203                                      (car (car (cdr active)))))
204                               (car (car (cdr active)))
205                               (cdr (car (cdr active)))
206                               (car active))))
207             t)))))
208
209 (defun nnbabyl-request-scan (&optional group server)
210   (nnbabyl-read-mbox)
211   (nnmail-get-new-mail 
212    'nnbabyl 
213    (lambda ()
214      (save-excursion
215        (set-buffer nnbabyl-mbox-buffer)
216        (save-buffer)))
217    nnbabyl-mbox-file group
218    (lambda ()
219      (save-excursion
220        (let ((in-buf (current-buffer)))
221          (goto-char (point-min))
222          (while (search-forward "\n\^_\n" nil t)
223            (delete-char -1))
224          (set-buffer nnbabyl-mbox-buffer)
225          (goto-char (point-max))
226          (search-backward "\n\^_" nil t)
227          (goto-char (match-end 0))
228          (insert-buffer-substring in-buf))))))
229
230 (defun nnbabyl-close-group (group &optional server)
231   t)
232
233 (defun nnbabyl-request-create-group (group &optional server) 
234   (nnmail-activate 'nnbabyl)
235   (or (assoc group nnbabyl-group-alist)
236       (let (active)
237         (setq nnbabyl-group-alist (cons (list group (setq active (cons 1 0)))
238                                         nnbabyl-group-alist))
239         (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)))
240   t)
241
242 (defun nnbabyl-request-list (&optional server)
243   (save-excursion
244     (or (nnmail-find-file nnbabyl-active-file)
245         (progn
246           (setq nnbabyl-group-alist (nnmail-get-active))
247           (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
248           (nnmail-find-file nnbabyl-active-file)))))
249
250 (defun nnbabyl-request-newgroups (date &optional server)
251   (nnbabyl-request-list server))
252
253 (defun nnbabyl-request-list-newsgroups (&optional server)
254   (setq nnbabyl-status-string "nnbabyl: LIST NEWSGROUPS is not implemented.")
255   nil)
256
257 (defun nnbabyl-request-post (&optional server)
258   (mail-send-and-exit nil))
259
260 (defun nnbabyl-request-expire-articles
261   (articles newsgroup &optional server force)
262   (nnbabyl-possibly-change-newsgroup newsgroup)
263   (let* ((days (or (and nnmail-expiry-wait-function
264                         (funcall nnmail-expiry-wait-function newsgroup))
265                    nnmail-expiry-wait))
266          (is-old t)
267          rest)
268     (nnmail-activate 'nnbabyl)
269
270     (save-excursion 
271       (set-buffer nnbabyl-mbox-buffer)
272       (set-text-properties (point-min) (point-max) nil)
273       (while (and articles is-old)
274         (goto-char (point-min))
275         (if (search-forward (nnbabyl-article-string (car articles)) nil t)
276             (if (or force
277                     (setq is-old
278                           (> (nnmail-days-between 
279                               (current-time-string)
280                               (buffer-substring 
281                                (point) (progn (end-of-line) (point))))
282                              days)))
283                 (progn
284                   (and gnus-verbose-backends
285                        (message "Deleting article %d in %s..." 
286                                 (car articles) newsgroup))
287                   (nnbabyl-delete-mail))
288               (setq rest (cons (car articles) rest))))
289         (setq articles (cdr articles)))
290       (save-buffer)
291       ;; Find the lowest active article in this group.
292       (let ((active (nth 1 (assoc newsgroup nnbabyl-group-alist))))
293         (goto-char (point-min))
294         (while (and (not (search-forward
295                           (nnbabyl-article-string (car active)) nil t))
296                     (<= (car active) (cdr active)))
297           (setcar active (1+ (car active)))
298           (goto-char (point-min))))
299       (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
300       (nconc rest articles))))
301
302 (defun nnbabyl-request-move-article 
303   (article group server accept-form &optional last)
304   (nnbabyl-possibly-change-newsgroup group)
305   (let ((buf (get-buffer-create " *nnbabyl move*"))
306         result)
307     (and 
308      (nnbabyl-request-article article group server)
309      (save-excursion
310        (set-buffer buf)
311        (insert-buffer-substring nntp-server-buffer)
312        (goto-char (point-min))
313        (if (re-search-forward 
314             "^X-Gnus-Newsgroup:" 
315             (save-excursion (search-forward "\n\n" nil t) (point)) t)
316            (delete-region (progn (beginning-of-line) (point))
317                           (progn (forward-line 1) (point))))
318        (setq result (eval accept-form))
319        (kill-buffer (current-buffer))
320        result)
321      (save-excursion
322        (set-buffer nnbabyl-mbox-buffer)
323        (goto-char (point-min))
324        (if (search-forward (nnbabyl-article-string article) nil t)
325            (nnbabyl-delete-mail))
326        (and last (save-buffer))))
327     result))
328
329 (defun nnbabyl-request-accept-article (group &optional last)
330   (let ((buf (current-buffer))
331         result beg)
332     (and 
333      (nnmail-activate 'nnbabyl)
334      (save-excursion
335        (goto-char (point-min))
336        (search-forward "\n\n" nil t)
337        (forward-line -1)
338        (save-excursion
339          (while (re-search-backward "^X-Gnus-Newsgroup: " beg t)
340            (delete-region (point) (progn (forward-line 1) (point)))))
341        (let ((nnmail-split-methods
342               (if (stringp group) (list (list group "")) 
343                 nnmail-split-methods)))
344          (setq result (car (nnbabyl-save-mail))))
345        (set-buffer nnbabyl-mbox-buffer)
346        (goto-char (point-max))
347        (search-backward "\n\^_")
348        (goto-char (match-end 0))
349        (insert-buffer-substring buf)
350        (and last (progn 
351                    (save-buffer)
352                    (nnmail-save-active
353                     nnbabyl-group-alist nnbabyl-active-file)))
354        result))))
355
356 (defun nnbabyl-request-replace-article (article group buffer)
357   (nnbabyl-possibly-change-newsgroup group)
358   (save-excursion
359     (set-buffer nnbabyl-mbox-buffer)
360     (goto-char (point-min))
361     (if (not (search-forward (nnbabyl-article-string article) nil t))
362         nil
363       (nnbabyl-delete-mail t t)
364       (insert-buffer-substring buffer)
365       (save-buffer)
366       t)))
367
368 (defun nnbabyl-request-delete-group (group &optional force server)
369   (nnbabyl-possibly-change-newsgroup group)
370   ;; Delete all articles in GROUP.
371   (if (not force)
372       ()                                ; Don't delete the articles.
373     (save-excursion
374       (set-buffer nnbabyl-mbox-buffer)
375       (goto-char (point-min))
376       ;; Delete all articles in this group.
377       (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"))
378             found)
379         (while (search-forward ident nil t)
380           (setq found t)
381           (nnbabyl-delete-mail))
382         (and found (save-buffer)))))
383   ;; Remove the group from all structures.
384   (setq nnbabyl-group-alist 
385         (delq (assoc group nnbabyl-group-alist) nnbabyl-group-alist)
386         nnbabyl-current-group nil)
387   ;; Save the active file.
388   (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
389   t)
390
391 (defun nnbabyl-request-rename-group (group new-name &optional server)
392   (nnbabyl-possibly-change-newsgroup group)
393   (save-excursion
394     (set-buffer nnbabyl-mbox-buffer)
395     (goto-char (point-min))
396     (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"))
397           (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":"))
398           found)
399       (while (search-forward ident nil t)
400         (replace-match new-ident t t)
401         (setq found t))
402       (and found (save-buffer))))
403   (let ((entry (assoc group nnbabyl-group-alist)))
404     (and entry (setcar entry new-name))
405     (setq nnbabyl-current-group nil)
406     ;; Save the new group alist.
407     (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
408     t))
409
410 \f
411 ;;; Internal functions.
412
413 ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
414 ;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox
415 ;; delimeter line.
416 (defun nnbabyl-delete-mail (&optional force leave-delim)
417   ;; Delete the current X-Gnus-Newsgroup line.
418   (or force
419       (delete-region
420        (progn (beginning-of-line) (point))
421        (progn (forward-line 1) (point))))
422   ;; Beginning of the article.
423   (save-excursion
424     (save-restriction
425       (widen)
426       (narrow-to-region
427        (save-excursion
428          (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
429          (if leave-delim (progn (forward-line 1) (point))
430            (match-beginning 0)))
431        (progn
432          (forward-line 1)
433          (or (and (re-search-forward (concat "^" nnbabyl-mail-delimiter) 
434                                      nil t)
435                   (if (and (not (bobp)) leave-delim)
436                       (progn (forward-line -2) (point))
437                     (match-beginning 0)))
438              (point-max))))
439       (goto-char (point-min))
440       ;; Only delete the article if no other groups owns it as well.
441       (if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
442           (delete-region (point-min) (point-max))))))
443
444 (defun nnbabyl-possibly-change-newsgroup (newsgroup)
445   (if (or (not nnbabyl-mbox-buffer)
446           (not (buffer-name nnbabyl-mbox-buffer)))
447       (save-excursion (nnbabyl-read-mbox)))
448   (or nnbabyl-group-alist
449       (nnmail-activate 'nnbabyl))
450   (if newsgroup
451       (if (assoc newsgroup nnbabyl-group-alist)
452           (setq nnbabyl-current-group newsgroup)
453         (setq nnbabyl-status-string "No such group in file")
454         nil)))
455
456 (defun nnbabyl-article-string (article)
457   (if (numberp article)
458       (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":" 
459               (int-to-string article) " ")
460     (concat "\nMessage-ID: " article)))
461
462 (defun nnbabyl-article-group-number ()
463   (save-excursion
464     (goto-char (point-min))
465     (and (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
466                             nil t)
467          (cons (buffer-substring (match-beginning 1) (match-end 1))
468                (string-to-int
469                 (buffer-substring (match-beginning 2) (match-end 2)))))))
470
471 (defun nnbabyl-insert-lines ()
472   "Insert how many lines and chars there are in the body of the mail."
473   (let (lines chars)
474     (save-excursion
475       (goto-char (point-min))
476       (if (search-forward "\n\n" nil t) 
477           (progn
478             ;; There may be an EOOH line here...
479             (if (looking-at "\\*\\*\\* EOOH \\*\\*\\*")
480                 (search-forward "\n\n" nil t))
481             (setq chars (- (point-max) (point)))
482             (setq lines (- (count-lines (point) (point-max)) 1))
483             ;; Move back to the end of the headers. 
484             (goto-char (point-min))
485             (search-forward "\n\n" nil t)
486             (forward-char -1)
487             (save-excursion
488               (if (re-search-backward "^Lines: " nil t)
489                   (delete-region (point) (progn (forward-line 1) (point)))))
490             (insert (format "Lines: %d\n" lines))
491             chars)))))
492
493 (defun nnbabyl-save-mail ()
494   ;; Called narrowed to an article.
495   (let ((group-art (nreverse (nnmail-article-group 'nnbabyl-active-number))))
496     (nnbabyl-insert-lines)
497     (nnmail-insert-xref group-art)
498     (nnbabyl-insert-newsgroup-line group-art)
499     (run-hooks 'nnbabyl-prepare-save-mail-hook)
500     group-art))
501
502 (defun nnbabyl-insert-newsgroup-line (group-art)
503   (save-excursion
504     (goto-char (point-min))
505     (while (looking-at "From ")
506       (replace-match "Mail-from: From " t t)
507       (forward-line 1))
508     ;; If there is a C-l at the beginning of the narrowed region, this
509     ;; isn't really a "save", but rather a "scan".
510     (goto-char (point-min))
511     (or (looking-at "\^L")
512         (save-excursion
513           (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
514           (goto-char (point-max))
515           (insert "\^_\n")))
516     (if (search-forward "\n\n" nil t)
517         (progn
518           (forward-char -1)
519           (while group-art
520             (insert (format "X-Gnus-Newsgroup: %s:%d   %s\n" 
521                             (car (car group-art)) (cdr (car group-art))
522                             (current-time-string)))
523             (setq group-art (cdr group-art)))))
524     t))
525
526 (defun nnbabyl-active-number (group)
527   ;; Find the next article number in GROUP.
528   (let ((active (car (cdr (assoc group nnbabyl-group-alist)))))
529     (if active
530         (setcdr active (1+ (cdr active)))
531       ;; This group is new, so we create a new entry for it.
532       ;; This might be a bit naughty... creating groups on the drop of
533       ;; a hat, but I don't know...
534       (setq nnbabyl-group-alist (cons (list group (setq active (cons 1 1)))
535                                       nnbabyl-group-alist)))
536     (cdr active)))
537
538 (defun nnbabyl-read-mbox ()
539   (nnmail-activate 'nnbabyl)
540   (or (file-exists-p nnbabyl-mbox-file)
541       (save-excursion
542         (set-buffer (setq nnbabyl-mbox-buffer
543                           (create-file-buffer nnbabyl-mbox-file)))
544         (setq buffer-file-name nnbabyl-mbox-file)
545         (insert "BABYL OPTIONS:\n\n\^_")
546         (write-region (point-min) (point-max) nnbabyl-mbox-file t 'nomesg)))
547
548   (if (and nnbabyl-mbox-buffer
549            (buffer-name nnbabyl-mbox-buffer)
550            (save-excursion
551              (set-buffer nnbabyl-mbox-buffer)
552              (= (buffer-size) (nth 7 (file-attributes nnbabyl-mbox-file)))))
553       ()
554     (save-excursion
555       (let ((delim (concat "^" nnbabyl-mail-delimiter))
556             start end)
557         (set-buffer (setq nnbabyl-mbox-buffer 
558                           (nnheader-find-file-noselect 
559                            nnbabyl-mbox-file nil 'raw)))
560         (buffer-disable-undo (current-buffer))
561         (widen)
562         (setq buffer-read-only nil)
563         (fundamental-mode)
564         
565         (goto-char (point-min))
566         (re-search-forward delim nil t)
567         (setq start (match-end 0))
568         (while (re-search-forward delim nil t)
569           (setq end (match-end 0))
570           (or (search-backward "\nX-Gnus-Newsgroup: " start t)
571               (progn
572                 (goto-char end)
573                 (save-excursion
574                   (save-restriction
575                     (goto-char start)
576                     (narrow-to-region start end)
577                     (nnbabyl-save-mail)
578                     (setq end (point-max))))))
579           (goto-char (setq start end)))
580         (and (buffer-modified-p (current-buffer)) (save-buffer))
581         (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)))))
582
583 (defun nnbabyl-remove-incoming-delims ()
584   (goto-char (point-min))
585   (while (search-forward "\^_" nil t)
586     (replace-match "?" t t)))
587
588 (provide 'nnbabyl)
589
590 ;;; nnbabyl.el ends here