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

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