cgit.sxemacs.org Git - gnus/blob - lisp/nnbabyl.el

   1 ;;; nnbabyl.el --- mail mbox access for Gnus
   2 ;; Copyright (C) 1995 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars 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 ;;; Code:
  27
  28 (require 'nnheader)
  29 (require 'rmail)
  30 (require 'nnmail)
  31
  32 (defvar nnbabyl-mbox-file (expand-file-name "~/RMAIL")
  33   "The name of the mail box file in the users home directory.")
  34
  35 (defvar nnbabyl-active-file (expand-file-name "~/.rmail-active")
  36   "The name of the active file for the mail box.")
  37
  38 (defvar nnbabyl-get-new-mail t
  39   "If non-nil, nnml will check the incoming mail file and split the mail.")
  40
  41 \f
  42
  43 (defvar nnbabyl-mail-delimiter "\^_")
  44
  45 (defconst nnbabyl-version "nnbabyl 0.1"
  46   "nnbabyl version.")
  47
  48 (defvar nnbabyl-current-group nil
  49   "Current nnbabyl news group directory.")
  50
  51 (defconst nnbabyl-mbox-buffer " *nnbabyl mbox buffer*")
  52
  53 (defvar nnbabyl-status-string "")
  54
  55 (defvar nnbabyl-group-alist nil)
  56
  57 ;;; Interface functions
  58
  59 (defun nnbabyl-retrieve-headers (sequence &optional newsgroup server)
  60   "Retrieve the headers for the articles in SEQUENCE.
  61 Newsgroup must be selected before calling this function."
  62   (save-excursion
  63     (set-buffer nntp-server-buffer)
  64     (erase-buffer)
  65     (let ((file nil)
  66           (number (length sequence))
  67           (count 0)
  68           beg article art-string start stop)
  69       (nnbabyl-possibly-change-newsgroup newsgroup)
  70       (while sequence
  71         (setq article (car sequence))
  72         (setq art-string (nnbabyl-article-string article))
  73         (set-buffer nnbabyl-mbox-buffer)
  74         (if (or (search-forward art-string nil t)
  75                 (progn (goto-char 1)
  76                        (search-forward art-string nil t)))
  77             (progn
  78               (setq start
  79                     (save-excursion
  80                       (re-search-backward
  81                        (concat "^" nnbabyl-mail-delimiter) nil t)
  82                       (while (and (not (looking-at ".+:"))
  83                                   (zerop (forward-line 1))))
  84                       (point)))
  85               (search-forward "\n\n" nil t)
  86               (setq stop (1- (point)))
  87               (set-buffer nntp-server-buffer)
  88               (insert (format "221 %d Article retrieved.\n" article))
  89               (setq beg (point))
  90               (insert-buffer-substring nnbabyl-mbox-buffer start stop)
  91               (goto-char (point-max))
  92               (insert ".\n")))
  93         (setq sequence (cdr sequence))
  94         (setq count (1+ count))
  95         (and (numberp nnmail-large-newsgroup)
  96              (> number nnmail-large-newsgroup)
  97              (zerop (% count 20))
  98              gnus-verbose-backends
  99              (message "nnbabyl: Receiving headers... %d%%"
 100                       (/ (* count 100) number))))
 101
 102       (and (numberp nnmail-large-newsgroup)
 103            (> number nnmail-large-newsgroup)
 104            gnus-verbose-backends
 105            (message "nnbabyl: Receiving headers... done"))
 106
 107       ;; Fold continuation lines.
 108       (goto-char 1)
 109       (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
 110         (replace-match " " t t))
 111       'headers)))
 112
 113 (defun nnbabyl-open-server (host &optional service)
 114   "Open mbox backend."
 115   (setq nnbabyl-status-string "")
 116   (setq nnbabyl-group-alist nil)
 117   (nnheader-init-server-buffer))
 118
 119 (defun nnbabyl-close-server (&optional server)
 120   "Close news server."
 121   t)
 122
 123 (defun nnbabyl-server-opened (&optional server)
 124   "Return server process status, T or NIL.
 125 If the stream is opened, return T, otherwise return NIL."
 126   (and nntp-server-buffer
 127        (get-buffer nntp-server-buffer)))
 128
 129 (defun nnbabyl-status-message ()
 130   "Return server status response as string."
 131   nnbabyl-status-string)
 132
 133 (defun nnbabyl-request-article (article &optional newsgroup server buffer)
 134   "Select ARTICLE by number."
 135   (nnbabyl-possibly-change-newsgroup newsgroup)
 136   (if (stringp article)
 137       nil
 138     (save-excursion
 139       (set-buffer nnbabyl-mbox-buffer)
 140       (goto-char 1)
 141       (if (search-forward (nnbabyl-article-string article) nil t)
 142           (let (start stop)
 143             (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
 144             (while (and (not (looking-at ".+:"))
 145                         (zerop (forward-line 1))))
 146             (setq start (point))
 147             (or (and (re-search-forward
 148                       (concat "^" nnbabyl-mail-delimiter) nil t)
 149                      (forward-line -1))
 150                 (goto-char (point-max)))
 151             (setq stop (point))
 152             (let ((nntp-server-buffer (or buffer nntp-server-buffer)))
 153               (set-buffer nntp-server-buffer)
 154               (erase-buffer)
 155               (insert-buffer-substring nnbabyl-mbox-buffer start stop)
 156               (goto-char (point-min))
 157               (if (search-forward "\n*** EOOH ***" nil t)
 158                   (progn
 159                     (delete-region (progn (beginning-of-line) (point))
 160                                    (or (search-forward "\n\n" nil t)
 161                                        (point)))))
 162               t))))))
 163
 164 (defun nnbabyl-request-group (group &optional server dont-check)
 165   "Select news GROUP."
 166   (save-excursion
 167     (if (nnbabyl-possibly-change-newsgroup group)
 168         (if dont-check
 169             t
 170           (nnbabyl-get-new-mail)
 171           (save-excursion
 172             (set-buffer nntp-server-buffer)
 173             (erase-buffer)
 174             (let ((active (assoc group nnbabyl-group-alist)))
 175               (insert (format "211 %d %d %d %s\n"
 176                               (1+ (- (cdr (car (cdr active)))
 177                                      (car (car (cdr active)))))
 178                               (car (car (cdr active)))
 179                               (cdr (car (cdr active)))
 180                               (car active))))
 181             t)))))
 182
 183 (defun nnbabyl-close-group (group &optional server)
 184   t)
 185
 186 (defun nnbabyl-request-list (&optional server)
 187   "List active newsgoups."
 188   (if server (nnbabyl-get-new-mail))
 189   (nnmail-find-file nnbabyl-active-file))
 190
 191 (defun nnbabyl-request-newgroups (date &optional server)
 192   "List groups created after DATE."
 193   (nnbabyl-request-list server))
 194
 195 (defun nnbabyl-request-list-newsgroups (&optional server)
 196   "List newsgroups (defined in NNTP2)."
 197   (setq nnbabyl-status-string "nnbabyl: LIST NEWSGROUPS is not implemented.")
 198   nil)
 199
 200 (defun nnbabyl-request-post (&optional server)
 201   "Post a new news in current buffer."
 202   (mail-send-and-exit nil))
 203
 204 (fset 'nnbabyl-request-post-buffer 'nnmail-request-post-buffer)
 205
 206 (defun nnbabyl-request-expire-articles (articles newsgroup &optional server force)
 207   "Expire all articles in the ARTICLES list in group GROUP.
 208 The list of unexpired articles will be returned (ie. all articles that
 209 were too fresh to be expired).
 210 If FORCE is non-nil, the ARTICLES will be deleted without looking at
 211 the date."
 212   (nnbabyl-possibly-change-newsgroup newsgroup)
 213   (let* ((days (or (and nnmail-expiry-wait-function
 214                         (funcall nnmail-expiry-wait-function newsgroup))
 215                    nnmail-expiry-wait))
 216          article rest)
 217     (save-excursion
 218       (set-buffer nnbabyl-mbox-buffer)
 219       (while articles
 220         (goto-char 1)
 221         (if (search-forward (nnbabyl-article-string (car articles)) nil t)
 222             (if (or force
 223                     (> (nnmail-days-between
 224                         (current-time-string)
 225                         (buffer-substring
 226                          (point) (progn (end-of-line) (point))))
 227                        days))
 228                 (progn
 229                   (and gnus-verbose-backends
 230                        (message "Deleting: %s" (car articles)))
 231                   (nnbabyl-delete-mail))
 232               (setq rest (cons (car articles) rest))))
 233         (setq articles (cdr articles)))
 234       (save-buffer)
 235       rest)))
 236
 237 (defun nnbabyl-request-move-article (article group server accept-form)
 238   (nnbabyl-possibly-change-newsgroup group)
 239   (let ((buf (get-buffer-create " *nnbabyl move*"))
 240         result)
 241     (and
 242      (nnbabyl-request-article article group server)
 243      (save-excursion
 244        (set-buffer buf)
 245        (insert-buffer-substring nntp-server-buffer)
 246        (goto-char (point-min))
 247        (if (re-search-forward
 248             "^X-Gnus-Newsgroup:"
 249             (save-excursion (search-forward "\n\n" nil t) (point)) t)
 250            (delete-region (progn (beginning-of-line) (point))
 251                           (progn (forward-line 1) (point))))
 252        (setq result (eval accept-form))
 253        (kill-buffer (current-buffer))
 254        result)
 255      (save-excursion
 256        (set-buffer nnbabyl-mbox-buffer)
 257        (goto-char 1)
 258        (if (search-forward (nnbabyl-article-string article) nil t)
 259            (nnbabyl-delete-mail))
 260        (save-buffer)))
 261     result))
 262
 263 (defun nnbabyl-request-accept-article (group)
 264   (let ((buf (current-buffer))
 265         result beg)
 266     (and
 267      (setq nnbabyl-group-alist (nnmail-get-active))
 268      (save-excursion
 269        (set-buffer nnbabyl-mbox-buffer)
 270        (setq beg (goto-char (point-max)))
 271        (insert-buffer-substring buf)
 272        (goto-char beg)
 273        (if (stringp group)
 274            (progn
 275              (search-forward "\n\n" nil t)
 276              (forward-line -1)
 277              (save-excursion
 278                (while (re-search-backward "^X-Gnus-Newsgroup: " beg t)
 279                  (delete-region (point) (progn (forward-line 1) (point)))))
 280              (setq result (nnbabyl-insert-newsgroup-line group)))
 281          (setq result (nnbabyl-save-mail)))
 282        (save-buffer)
 283        result)
 284      (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))
 285     result))
 286
 287 (defun nnbabyl-request-replace-article (article group buffer)
 288   (nnbabyl-possibly-change-newsgroup group)
 289   (save-excursion
 290     (set-buffer nnbabyl-mbox-buffer)
 291     (goto-char 1)
 292     (if (not (search-forward (nnbabyl-article-string article) nil t))
 293         nil
 294       (nnbabyl-delete-mail t t)
 295       (insert-buffer-substring buffer)
 296       (save-buffer)
 297       t)))
 298
 299 \f
 300 ;;; Low-Level Interface
 301
 302 (defun nnbabyl-delete-mail (&optional force leave-delim)
 303   "If FORCE, delete article no matter how many X-Gnus-Newsgroup
 304 headers there are. If LEAVE-DELIM, don't delete the Unix mbox
 305 delimeter line."
 306   ;; Delete the current X-Gnus-Newsgroup line.
 307   (or force
 308       (delete-region
 309        (progn (beginning-of-line) (point))
 310        (progn (forward-line 1) (point))))
 311   ;; Beginning of the article.
 312   (save-excursion
 313     (save-restriction
 314       (narrow-to-region
 315        (save-excursion
 316          (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
 317          (if leave-delim (progn (forward-line 1) (point))
 318            (match-beginning 0)))
 319        (progn
 320          (forward-line 1)
 321          (or (and (re-search-forward (concat "^" nnbabyl-mail-delimiter)
 322                                      nil t)
 323                   (if (and (not (bobp)) leave-delim)
 324                       (progn (forward-line -2) (point))
 325                     (match-beginning 0)))
 326              (point-max))))
 327       (goto-char (point-min))
 328       ;; Only delete the article if no other groups owns it as well.
 329       (if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
 330           (delete-region (point-min) (point-max))))))
 331
 332 (defun nnbabyl-possibly-change-newsgroup (newsgroup)
 333   (if (not (get-buffer nnbabyl-mbox-buffer))
 334       (save-excursion
 335         (let ((buf (or (get-buffer (file-name-nondirectory nnbabyl-mbox-file))
 336                        (create-file-buffer nnbabyl-mbox-file))))
 337           (set-buffer (setq nnbabyl-mbox-buffer buf))
 338           (insert-file-contents nnbabyl-mbox-file)
 339           (setq buffer-file-name nnbabyl-mbox-file))
 340         (buffer-disable-undo (current-buffer))))
 341   (if (not nnbabyl-group-alist)
 342       (setq nnbabyl-group-alist (nnmail-get-active)))
 343   (if newsgroup
 344       (if (assoc newsgroup nnbabyl-group-alist)
 345           (setq nnbabyl-current-group newsgroup))))
 346
 347 (defun nnbabyl-article-string (article)
 348   (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"
 349           (int-to-string article)))
 350
 351 (defun nnbabyl-save-mail ()
 352   "Called narrowed to an article."
 353   (let ((group-art (nreverse (nnmail-article-group 'nnbabyl-active-number))))
 354     (nnmail-insert-lines)
 355     (nnmail-insert-xref group-art)
 356     (nnbabyl-insert-newsgroup-line group-art)))
 357
 358 (defun nnbabyl-insert-newsgroup-line (group-art)
 359   (save-excursion
 360     (goto-char (point-min))
 361     (or (looking-at "\^_")
 362         (insert "\^_\^L\n0, unseen,,\n*** EOOH ***\n"))
 363     (while (looking-at "From ")
 364       (replace-match "Mail-from: ")
 365       (forward-line 1))
 366     (if (search-forward "\n\n" nil t)
 367         (progn
 368           (forward-char -1)
 369           (while group-art
 370             (insert (format "X-Gnus-Newsgroup: %s:%d   %s\n"
 371                             (car (car group-art)) (cdr (car group-art))
 372                             (current-time-string)))
 373             (setq group-art (cdr group-art)))))))
 374
 375 (defun nnbabyl-active-number (group)
 376   "Find the next article number in GROUP."
 377   (let ((active (car (cdr (assoc group nnbabyl-group-alist)))))
 378     (setcdr active (1+ (cdr active)))
 379     (cdr active)))
 380
 381 (defun nnbabyl-read-mbox ()
 382   (nnbabyl-request-list)
 383   (setq nnbabyl-group-alist (nnmail-get-active))
 384   (if (not (file-exists-p nnbabyl-mbox-file))
 385       (write-region 1 1 nnbabyl-mbox-file t 'nomesg))
 386   (if (and nnbabyl-mbox-buffer
 387            (get-buffer nnbabyl-mbox-buffer)
 388            (buffer-name nnbabyl-mbox-buffer)
 389            (save-excursion
 390              (set-buffer nnbabyl-mbox-buffer)
 391              (= (buffer-size) (nth 7 (file-attributes nnbabyl-mbox-file)))))
 392       ()
 393     (save-excursion
 394       (let ((delim (concat "^" nnbabyl-mail-delimiter))
 395             (buf (or (get-buffer (file-name-nondirectory nnbabyl-mbox-file))
 396                      (create-file-buffer nnbabyl-mbox-file)))
 397             start end)
 398         (set-buffer (setq nnbabyl-mbox-buffer buf))
 399         (insert-file-contents nnbabyl-mbox-file)
 400         (setq buffer-file-name nnbabyl-mbox-file)
 401
 402         (buffer-disable-undo (current-buffer))
 403         (goto-char (point-min))
 404         (while (re-search-forward delim nil t)
 405           (setq start (match-beginning 0))
 406           (if (not (search-forward "\nX-Gnus-Newsgroup: "
 407                                    (save-excursion
 408                                      (setq end
 409                                            (or
 410                                             (and
 411                                              (re-search-forward delim nil t)
 412                                              (match-beginning 0))
 413                                             (point-max))))
 414                                    t))
 415               (goto-char end)
 416               (save-excursion
 417                 (save-restriction
 418                   (goto-char start)
 419                   (narrow-to-region start end)
 420                   (nnbabyl-save-mail))))
 421           )))))
 422
 423 (defun nnbabyl-get-new-mail ()
 424   (let (incoming)
 425     (nnbabyl-read-mbox)
 426     (if (and nnmail-spool-file
 427              (file-exists-p nnmail-spool-file)
 428              (> (nth 7 (file-attributes nnmail-spool-file)) 0))
 429         (progn
 430           (and gnus-verbose-backends
 431                (message "nnbabyl: Reading incoming mail..."))
 432           (setq incoming
 433                 (nnmail-move-inbox nnmail-spool-file
 434                                    (concat nnbabyl-mbox-file "-Incoming")))
 435           (save-excursion
 436             (let ((in-buf (nnmail-split-incoming
 437                            incoming 'nnbabyl-save-mail t)))
 438               (set-buffer nnbabyl-mbox-buffer)
 439               (goto-char (point-max))
 440               (search-backward "\n\^_" nil t)
 441               (insert-buffer-substring in-buf)
 442               (kill-buffer in-buf)))
 443           (run-hooks 'nnmail-read-incoming-hook)
 444           (and gnus-verbose-backends
 445                (message "nnbabyl: Reading incoming mail...done"))))
 446     (and (buffer-modified-p nnbabyl-mbox-buffer)
 447          (save-excursion
 448            (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
 449            (set-buffer nnbabyl-mbox-buffer)
 450            (save-buffer)))
 451     ;; (if incoming (delete-file incoming))
 452     ))
 453
 454 (provide 'nnbabyl)
 455
 456 ;;; nnbabyl.el ends here