cgit.sxemacs.org Git - gnus/blob - 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 0.1"
  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
  59 \f
  60
  61 (defvar nnbabyl-current-server nil)
  62 (defvar nnbabyl-server-alist nil)
  63 (defvar nnbabyl-server-variables
  64   (list
  65    (list 'nnbabyl-mbox-file nnbabyl-mbox-file)
  66    (list 'nnbabyl-active-file nnbabyl-active-file)
  67    (list 'nnbabyl-get-new-mail nnbabyl-get-new-mail)
  68    '(nnbabyl-current-group nil)
  69    '(nnbabyl-status-string "")
  70    '(nnbabyl-group-alist nil)))
  71
  72 \f
  73
  74 ;;; Interface functions
  75
  76 (defun nnbabyl-retrieve-headers (sequence &optional newsgroup server)
  77   (save-excursion
  78     (set-buffer nntp-server-buffer)
  79     (erase-buffer)
  80     (let ((file nil)
  81           (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       (goto-char (point-min))
 119       (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
 120         (replace-match " " t t))
 121       'headers)))
 122
 123 (defun nnbabyl-open-server (server &optional defs)
 124   (nnheader-init-server-buffer)
 125   (if (equal server nnbabyl-current-server)
 126       t
 127     (if nnbabyl-current-server
 128         (setq nnbabyl-server-alist
 129               (cons (list nnbabyl-current-server
 130                           (nnheader-save-variables nnbabyl-server-variables))
 131                     nnbabyl-server-alist)))
 132     (let ((state (assoc server nnbabyl-server-alist)))
 133       (if state
 134           (progn
 135             (nnheader-restore-variables (nth 1 state))
 136             (setq nnbabyl-server-alist (delq state nnbabyl-server-alist)))
 137         (nnheader-set-init-variables nnbabyl-server-variables defs)))
 138     (setq nnbabyl-current-server server)))
 139
 140 (defun nnbabyl-close-server (&optional server)
 141   t)
 142
 143 (defun nnbabyl-server-opened (&optional server)
 144   (and (equal server nnbabyl-current-server)
 145        nntp-server-buffer
 146        (buffer-name nntp-server-buffer)))
 147
 148 (defun nnbabyl-status-message (&optional server)
 149   nnbabyl-status-string)
 150
 151 (defun nnbabyl-request-article (article &optional newsgroup server buffer)
 152   (nnbabyl-possibly-change-newsgroup newsgroup)
 153   (if (stringp article)
 154       nil
 155     (save-excursion
 156       (set-buffer nnbabyl-mbox-buffer)
 157       (goto-char (point-min))
 158       (if (search-forward (nnbabyl-article-string article) nil t)
 159           (let (start stop)
 160             (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
 161             (while (and (not (looking-at ".+:"))
 162                         (zerop (forward-line 1))))
 163             (setq start (point))
 164             (or (and (re-search-forward
 165                       (concat "^" nnbabyl-mail-delimiter) nil t)
 166                      (forward-line -1))
 167                 (goto-char (point-max)))
 168             (setq stop (point))
 169             (let ((nntp-server-buffer (or buffer nntp-server-buffer)))
 170               (set-buffer nntp-server-buffer)
 171               (erase-buffer)
 172               (insert-buffer-substring nnbabyl-mbox-buffer start stop)
 173               (goto-char (point-min))
 174               (if (search-forward "\n*** EOOH ***" nil t)
 175                   (progn
 176                     (delete-region (progn (beginning-of-line) (point))
 177                                    (or (search-forward "\n\n" nil t)
 178                                        (point)))))
 179               t))))))
 180
 181 (defun nnbabyl-request-group (group &optional server dont-check)
 182   (save-excursion
 183     (if (nnbabyl-possibly-change-newsgroup group)
 184         (if dont-check
 185             t
 186           (nnbabyl-get-new-mail group)
 187           (save-excursion
 188             (set-buffer nntp-server-buffer)
 189             (erase-buffer)
 190             (let ((active (assoc group nnbabyl-group-alist)))
 191               (insert (format "211 %d %d %d %s\n"
 192                               (1+ (- (cdr (car (cdr active)))
 193                                      (car (car (cdr active)))))
 194                               (car (car (cdr active)))
 195                               (cdr (car (cdr active)))
 196                               (car active))))
 197             t)))))
 198
 199 (defun nnbabyl-close-group (group &optional server)
 200   t)
 201
 202 (defun nnbabyl-request-list (&optional server)
 203   (if server (nnbabyl-get-new-mail))
 204   (save-excursion
 205     (or (nnmail-find-file nnbabyl-active-file)
 206         (progn
 207           (setq nnbabyl-group-alist (nnmail-get-active))
 208           (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
 209           (nnmail-find-file nnbabyl-active-file)))))
 210
 211 (defun nnbabyl-request-newgroups (date &optional server)
 212   (nnbabyl-request-list server))
 213
 214 (defun nnbabyl-request-list-newsgroups (&optional server)
 215   (setq nnbabyl-status-string "nnbabyl: LIST NEWSGROUPS is not implemented.")
 216   nil)
 217
 218 (defun nnbabyl-request-post (&optional server)
 219   (mail-send-and-exit nil))
 220
 221 (fset 'nnbabyl-request-post-buffer 'nnmail-request-post-buffer)
 222
 223 (defun nnbabyl-request-expire-articles (articles newsgroup &optional server force)
 224   (nnbabyl-possibly-change-newsgroup newsgroup)
 225   (let* ((days (or (and nnmail-expiry-wait-function
 226                         (funcall nnmail-expiry-wait-function newsgroup))
 227                    nnmail-expiry-wait))
 228          article rest)
 229     (save-excursion
 230       (set-buffer nnbabyl-mbox-buffer)
 231       (while articles
 232         (goto-char (point-min))
 233         (if (search-forward (nnbabyl-article-string (car articles)) nil t)
 234             (if (or force
 235                     (> (nnmail-days-between
 236                         (current-time-string)
 237                         (buffer-substring
 238                          (point) (progn (end-of-line) (point))))
 239                        days))
 240                 (progn
 241                   (and gnus-verbose-backends
 242                        (message "Deleting: %s" (car articles)))
 243                   (nnbabyl-delete-mail))
 244               (setq rest (cons (car articles) rest))))
 245         (setq articles (cdr articles)))
 246       (save-buffer)
 247       ;; Find the lowest active article in this group.
 248       (let ((active (nth 1 (assoc newsgroup nnbabyl-group-alist))))
 249         (goto-char (point-min))
 250         (while (not (search-forward
 251                      (nnbabyl-article-string (car active)) nil t))
 252           (setcar active (1+ (car active)))
 253           (goto-char (point-min))))
 254       (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
 255       rest)))
 256
 257 (defun nnbabyl-request-move-article
 258   (article group server accept-form &optional last)
 259   (nnbabyl-possibly-change-newsgroup group)
 260   (let ((buf (get-buffer-create " *nnbabyl move*"))
 261         result)
 262     (and
 263      (nnbabyl-request-article article group server)
 264      (save-excursion
 265        (set-buffer buf)
 266        (insert-buffer-substring nntp-server-buffer)
 267        (goto-char (point-min))
 268        (if (re-search-forward
 269             "^X-Gnus-Newsgroup:"
 270             (save-excursion (search-forward "\n\n" nil t) (point)) t)
 271            (delete-region (progn (beginning-of-line) (point))
 272                           (progn (forward-line 1) (point))))
 273        (setq result (eval accept-form))
 274        (kill-buffer (current-buffer))
 275        result)
 276      (save-excursion
 277        (set-buffer nnbabyl-mbox-buffer)
 278        (goto-char (point-min))
 279        (if (search-forward (nnbabyl-article-string article) nil t)
 280            (nnbabyl-delete-mail))
 281        (and last (save-buffer))))
 282     result))
 283
 284 (defun nnbabyl-request-accept-article (group &optional last)
 285   (let ((buf (current-buffer))
 286         result beg)
 287     (and
 288      (nnbabyl-request-list)
 289      (setq nnbabyl-group-alist (nnmail-get-active))
 290      (save-excursion
 291        (goto-char (point-min))
 292        (search-forward "\n\n" nil t)
 293        (forward-line -1)
 294        (save-excursion
 295          (while (re-search-backward "^X-Gnus-Newsgroup: " beg t)
 296            (delete-region (point) (progn (forward-line 1) (point)))))
 297        (let ((nnmail-split-methods
 298               (if (stringp group) (list (list group ""))
 299                 nnmail-split-methods)))
 300          (setq result (car (nnbabyl-save-mail))))
 301        (set-buffer nnbabyl-mbox-buffer)
 302        (goto-char (point-max))
 303        (search-backward "\n\^_")
 304        (goto-char (match-end 0))
 305        (insert-buffer buf)
 306        (and last (progn
 307                    (save-buffer)
 308                    (nnmail-save-active
 309                     nnbabyl-group-alist nnbabyl-active-file)))
 310        result))))
 311
 312 (defun nnbabyl-request-replace-article (article group buffer)
 313   (nnbabyl-possibly-change-newsgroup group)
 314   (save-excursion
 315     (set-buffer nnbabyl-mbox-buffer)
 316     (goto-char (point-min))
 317     (if (not (search-forward (nnbabyl-article-string article) nil t))
 318         nil
 319       (nnbabyl-delete-mail t t)
 320       (insert-buffer-substring buffer)
 321       (save-buffer)
 322       t)))
 323
 324 \f
 325 ;;; Low-Level Interface
 326
 327 ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
 328 ;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox
 329 ;; delimeter line.
 330 (defun nnbabyl-delete-mail (&optional force leave-delim)
 331   ;; Delete the current X-Gnus-Newsgroup line.
 332   (or force
 333       (delete-region
 334        (progn (beginning-of-line) (point))
 335        (progn (forward-line 1) (point))))
 336   ;; Beginning of the article.
 337   (save-excursion
 338     (save-restriction
 339       (narrow-to-region
 340        (save-excursion
 341          (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
 342          (if leave-delim (progn (forward-line 1) (point))
 343            (match-beginning 0)))
 344        (progn
 345          (forward-line 1)
 346          (or (and (re-search-forward (concat "^" nnbabyl-mail-delimiter)
 347                                      nil t)
 348                   (if (and (not (bobp)) leave-delim)
 349                       (progn (forward-line -2) (point))
 350                     (match-beginning 0)))
 351              (point-max))))
 352       (goto-char (point-min))
 353       ;; Only delete the article if no other groups owns it as well.
 354       (if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
 355           (delete-region (point-min) (point-max))))))
 356
 357 (defun nnbabyl-possibly-change-newsgroup (newsgroup)
 358   (if (or (not nnbabyl-mbox-buffer)
 359           (not (buffer-name nnbabyl-mbox-buffer)))
 360       (save-excursion (nnbabyl-read-mbox)))
 361   (or nnbabyl-group-alist
 362       (progn
 363         (nnbabyl-request-list)
 364         (setq nnbabyl-group-alist (nnmail-get-active))))
 365   (if newsgroup
 366       (if (assoc newsgroup nnbabyl-group-alist)
 367           (setq nnbabyl-current-group newsgroup)
 368         (setq nnbabyl-status-string "No such group in file")
 369         nil)))
 370
 371 (defun nnbabyl-article-string (article)
 372   (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"
 373           (int-to-string article) " "))
 374
 375 (defun nnbabyl-insert-lines ()
 376   "Insert how many lines and chars there are in the body of the mail."
 377   (let (lines chars)
 378     (save-excursion
 379       (goto-char (point-min))
 380       (if (search-forward "\n\n" nil t)
 381           (progn
 382             ;; There may be an EOOH line here...
 383             (if (looking-at "\\*\\*\\* EOOH \\*\\*\\*")
 384                 (search-forward "\n\n" nil t))
 385             (setq chars (- (point-max) (point)))
 386             (setq lines (- (count-lines (point) (point-max)) 1))
 387             ;; Move back to the end of the headers.
 388             (goto-char (point-min))
 389             (search-forward "\n\n" nil t)
 390             (forward-char -1)
 391             (save-excursion
 392               (if (re-search-backward "^Lines: " nil t)
 393                   (delete-region (point) (progn (forward-line 1) (point)))))
 394             (insert (format "Lines: %d\n" lines))
 395             chars)))))
 396
 397 (defun nnbabyl-save-mail ()
 398   ;; Called narrowed to an article.
 399   (let ((group-art (nreverse (nnmail-article-group 'nnbabyl-active-number))))
 400     (nnbabyl-insert-lines)
 401     (nnmail-insert-xref group-art)
 402     (nnbabyl-insert-newsgroup-line group-art)
 403     (run-hooks 'nnbabyl-prepare-save-mail-hook)
 404     group-art))
 405
 406 (defun nnbabyl-insert-newsgroup-line (group-art)
 407   (save-excursion
 408     (goto-char (point-min))
 409     ;; If there is a C-l at the beginning of the narrowed region, this
 410     ;; isn't really a "save", but rather a "scan".
 411     (while (looking-at "From ")
 412       (replace-match "Mail-from: From " t t)
 413       (forward-line 1))
 414     (goto-char (point-min))
 415     (or (looking-at "\^L")
 416         (save-excursion
 417           (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
 418           (goto-char (point-max))
 419           (insert "\^_\n")))
 420     (if (search-forward "\n\n" nil t)
 421         (progn
 422           (forward-char -1)
 423           (while group-art
 424             (insert (format "X-Gnus-Newsgroup: %s:%d   %s\n"
 425                             (car (car group-art)) (cdr (car group-art))
 426                             (current-time-string)))
 427             (setq group-art (cdr group-art)))))
 428     t))
 429
 430 (defun nnbabyl-active-number (group)
 431   ;; Find the next article number in GROUP.
 432   (let ((active (car (cdr (assoc group nnbabyl-group-alist)))))
 433     (setcdr active (1+ (cdr active)))
 434     (cdr active)))
 435
 436 (defun nnbabyl-read-mbox ()
 437   (nnbabyl-request-list)
 438   (setq nnbabyl-group-alist (nnmail-get-active))
 439   (or (file-exists-p nnbabyl-mbox-file)
 440       (save-excursion
 441         (set-buffer (setq nnbabyl-mbox-buffer
 442                           (create-file-buffer nnbabyl-mbox-file)))
 443         (setq buffer-file-name nnbabyl-mbox-file)
 444         (insert "BABYL OPTIONS:\n\n\^_")
 445         (write-region (point-min) (point-max) nnbabyl-mbox-file t 'nomesg)))
 446   (if (and nnbabyl-mbox-buffer
 447            (get-buffer nnbabyl-mbox-buffer)
 448            (buffer-name nnbabyl-mbox-buffer)
 449            (save-excursion
 450              (set-buffer nnbabyl-mbox-buffer)
 451              (= (buffer-size) (nth 7 (file-attributes nnbabyl-mbox-file)))))
 452       ()
 453     (save-excursion
 454       (let ((delim (concat "^" nnbabyl-mail-delimiter))
 455             (buf (or (get-buffer (file-name-nondirectory nnbabyl-mbox-file))
 456                      (create-file-buffer nnbabyl-mbox-file)))
 457             start end)
 458         (set-buffer (setq nnbabyl-mbox-buffer buf))
 459         (buffer-disable-undo (current-buffer))
 460
 461         (insert-file-contents nnbabyl-mbox-file)
 462         (setq buffer-file-name nnbabyl-mbox-file)
 463         (set-buffer-modified-p nil)
 464
 465         (goto-char (point-min))
 466         (while (re-search-forward delim nil t)
 467           (setq start (match-beginning 0))
 468           (if (and
 469                (save-excursion (re-search-forward delim nil t))
 470                (not (search-forward
 471                      "\nX-Gnus-Newsgroup: "
 472                      (save-excursion
 473                        (setq end (or (and (re-search-forward delim nil t)
 474                                           (match-beginning 0))
 475                                      (point-max)))) t)))
 476               (progn
 477                 (goto-char end)
 478                 (save-excursion
 479                   (save-restriction
 480                     (goto-char start)
 481                     (narrow-to-region (1+ start) end)
 482                     (nnbabyl-save-mail))))))
 483         (and (buffer-modified-p (current-buffer)) (save-buffer))
 484         (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)))))
 485
 486 (defun nnbabyl-get-new-mail (&optional group)
 487   "Read new incoming mail."
 488   (let ((spools (nnmail-get-spool-files group))
 489         incoming incomings)
 490     (nnbabyl-read-mbox)
 491     (if (or (not nnbabyl-get-new-mail) (not nnmail-spool-file))
 492         ()
 493       ;; We go through all the existing spool files and split the
 494       ;; mail from each.
 495       (while spools
 496         (and
 497          (file-exists-p (car spools))
 498          (> (nth 7 (file-attributes (car spools))) 0)
 499          (progn
 500            (and gnus-verbose-backends
 501                 (message "nnbabyl: Reading incoming mail..."))
 502            (setq incoming
 503                  (nnmail-move-inbox
 504                   (car spools) (concat nnbabyl-mbox-file "-Incoming")))
 505            (setq incomings (cons incoming incomings))
 506            (save-excursion
 507              (let ((in-buf (nnmail-split-incoming
 508                             incoming 'nnbabyl-save-mail t)))
 509                (set-buffer in-buf)
 510                (goto-char (point-min))
 511                (while (search-forward "\n\^_\n" nil t)
 512                  (delete-char -1))
 513                (set-buffer nnbabyl-mbox-buffer)
 514                (goto-char (point-max))
 515                (search-backward "\n\^_" nil t)
 516                (goto-char (match-end 0))
 517                (insert-buffer-substring in-buf)
 518                (kill-buffer in-buf)))))
 519         (setq spools (cdr spools)))
 520       ;; If we did indeed read any incoming spools, we save all info.
 521       (and (buffer-modified-p nnbabyl-mbox-buffer)
 522            (save-excursion
 523              (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
 524              (set-buffer nnbabyl-mbox-buffer)
 525              (save-buffer)))
 526       (while incomings
 527         ;; The following has been commented away, just to make sure
 528         ;; that nobody ever loses any mail. If you feel safe that
 529         ;; nnfolder will never do anything strange, just remove those
 530         ;; two semicolons, and avoid having lots of "Incoming*"
 531         ;; files.
 532         ;; (and (file-writable-p incoming) (delete-file incoming))
 533         (setq incomings (cdr incomings))))))
 534
 535 (provide 'nnbabyl)
 536
 537 ;;; nnbabyl.el ends here