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