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   (setq nnmbox-group-alist nil)
 113   (nnheader-init-server-buffer))
 114
 115 (defun nnmbox-close-server (&optional server)
 116   "Close news server."
 117   t)
 118
 119 (defun nnmbox-server-opened (&optional server)
 120   "Return server process status, T or NIL.
 121 If the stream is opened, return T, otherwise return NIL."
 122   (and nntp-server-buffer
 123        (get-buffer nntp-server-buffer)))
 124
 125 (defun nnmbox-status-message ()
 126   "Return server status response as string."
 127   nnmbox-status-string)
 128
 129 (defun nnmbox-request-article (article &optional newsgroup server buffer)
 130   "Select ARTICLE by number."
 131   (nnmbox-possibly-change-newsgroup newsgroup)
 132   (if (stringp article)
 133       nil
 134     (save-excursion
 135       (set-buffer nnmbox-mbox-buffer)
 136       (goto-char 1)
 137       (if (search-forward (nnmbox-article-string article) nil t)
 138           (let (start stop)
 139             (re-search-backward (concat "^" rmail-unix-mail-delimiter) nil t)
 140             (forward-line 1)
 141             (setq start (point))
 142             (or (and (re-search-forward
 143                       (concat "^" rmail-unix-mail-delimiter) nil t)
 144                      (forward-line -1))
 145                 (goto-char (point-max)))
 146             (setq stop (point))
 147             (let ((nntp-server-buffer (or buffer nntp-server-buffer)))
 148               (set-buffer nntp-server-buffer)
 149               (erase-buffer)
 150               (insert-buffer-substring nnmbox-mbox-buffer start stop)
 151               t))))))
 152
 153 (defun nnmbox-request-group (group &optional server dont-check)
 154   "Select news GROUP."
 155   (save-excursion
 156     (if (nnmbox-possibly-change-newsgroup group)
 157         (if dont-check
 158             t
 159           (nnmbox-get-new-mail)
 160           (save-excursion
 161             (set-buffer nntp-server-buffer)
 162             (erase-buffer)
 163             (let ((active (assoc group nnmbox-group-alist)))
 164               (insert (format "211 %d %d %d %s\n"
 165                               (1+ (- (cdr (car (cdr active)))
 166                                      (car (car (cdr active)))))
 167                               (car (car (cdr active)))
 168                               (cdr (car (cdr active)))
 169                               (car active))))
 170             t)))))
 171
 172 (defun nnmbox-close-group (group &optional server)
 173   t)
 174
 175 (defun nnmbox-request-list (&optional server)
 176   "List active newsgoups."
 177   (if server (nnmbox-get-new-mail))
 178   (nnmail-find-file nnmbox-active-file))
 179
 180 (defun nnmbox-request-newgroups (date &optional server)
 181   "List groups created after DATE."
 182   (nnmbox-request-list server))
 183
 184 (defun nnmbox-request-list-newsgroups (&optional server)
 185   "List newsgroups (defined in NNTP2)."
 186   (setq nnmbox-status-string "nnmbox: LIST NEWSGROUPS is not implemented.")
 187   nil)
 188
 189 (defun nnmbox-request-post (&optional server)
 190   "Post a new news in current buffer."
 191   (mail-send-and-exit nil))
 192
 193 (fset 'nnmbox-request-post-buffer 'nnmail-request-post-buffer)
 194
 195 (defun nnmbox-request-expire-articles (articles newsgroup &optional server force)
 196   "Expire all articles in the ARTICLES list in group GROUP.
 197 The list of unexpired articles will be returned (ie. all articles that
 198 were too fresh to be expired).
 199 If FORCE is non-nil, the ARTICLES will be deleted without looking at
 200 the date."
 201   (nnmbox-possibly-change-newsgroup newsgroup)
 202   (let* ((days (or (and nnmail-expiry-wait-function
 203                         (funcall nnmail-expiry-wait-function newsgroup))
 204                    nnmail-expiry-wait))
 205          article rest)
 206     (save-excursion
 207       (set-buffer nnmbox-mbox-buffer)
 208       (while articles
 209         (goto-char 1)
 210         (if (search-forward (nnmbox-article-string (car articles)) nil t)
 211             (if (or force
 212                     (> (nnmail-days-between
 213                         (current-time-string)
 214                         (buffer-substring
 215                          (point) (progn (end-of-line) (point))))
 216                        days))
 217                 (progn
 218                   (and gnus-verbose-backends
 219                        (message "Deleting: %s" (car articles)))
 220                   (nnmbox-delete-mail))
 221               (setq rest (cons (car articles) rest))))
 222         (setq articles (cdr articles)))
 223       (save-buffer)
 224       rest)))
 225
 226 (defun nnmbox-request-move-article (article group server accept-form)
 227   (nnmbox-possibly-change-newsgroup group)
 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 (defun nnmbox-request-replace-article (article group buffer)
 277   (nnmbox-possibly-change-newsgroup group)
 278   (save-excursion
 279     (set-buffer nnmbox-mbox-buffer)
 280     (goto-char 1)
 281     (if (not (search-forward (nnmbox-article-string article) nil t))
 282         nil
 283       (nnmbox-delete-mail t t)
 284       (insert-buffer-substring buffer)
 285       (save-buffer)
 286       t)))
 287
 288 \f
 289 ;;; Low-Level Interface
 290
 291 (defun nnmbox-delete-mail (&optional force leave-delim)
 292   "If FORCE, delete article no matter how many X-Gnus-Newsgroup
 293 headers there are. If LEAVE-DELIM, don't delete the Unix mbox
 294 delimeter line."
 295   ;; Delete the current X-Gnus-Newsgroup line.
 296   (or force
 297       (delete-region
 298        (progn (beginning-of-line) (point))
 299        (progn (forward-line 1) (point))))
 300   ;; Beginning of the article.
 301   (save-excursion
 302     (save-restriction
 303       (narrow-to-region
 304        (save-excursion
 305          (re-search-backward (concat "^" rmail-unix-mail-delimiter) nil t)
 306          (if leave-delim (progn (forward-line 1) (point))
 307            (match-beginning 0)))
 308        (progn
 309          (forward-line 1)
 310          (or (and (re-search-forward (concat "^" rmail-unix-mail-delimiter)
 311                                      nil t)
 312                   (if (and (not (bobp)) leave-delim)
 313                       (progn (forward-line -2) (point))
 314                     (match-beginning 0)))
 315              (point-max))))
 316       (goto-char (point-min))
 317       ;; Only delete the article if no other groups owns it as well.
 318       (if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
 319           (delete-region (point-min) (point-max))))))
 320
 321 (defun nnmbox-possibly-change-newsgroup (newsgroup)
 322   (if (not (get-buffer nnmbox-mbox-buffer))
 323       (save-excursion
 324         (set-buffer (setq nnmbox-mbox-buffer
 325                           (find-file-noselect nnmbox-mbox-file)))
 326         (buffer-disable-undo (current-buffer))))
 327   (if (not nnmbox-group-alist)
 328       (setq nnmbox-group-alist (nnmail-get-active)))
 329   (if newsgroup
 330       (if (assoc newsgroup nnmbox-group-alist)
 331           (setq nnmbox-current-group newsgroup))))
 332
 333 (defun nnmbox-article-string (article)
 334   (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"
 335           (int-to-string article)))
 336
 337 (defun nnmbox-save-mail ()
 338   "Called narrowed to an article."
 339   (let ((group-art (nreverse (nnmail-article-group 'nnmbox-active-number))))
 340     (nnmail-insert-lines)
 341     (nnmail-insert-xref group-art)
 342     (nnmbox-insert-newsgroup-line group-art)))
 343
 344 (defun nnmbox-insert-newsgroup-line (group-art)
 345   (save-excursion
 346     (goto-char (point-min))
 347     (if (search-forward "\n\n" nil t)
 348         (progn
 349           (forward-char -1)
 350           (while group-art
 351             (insert (format "X-Gnus-Newsgroup: %s:%d   %s\n"
 352                             (car (car group-art)) (cdr (car group-art))
 353                             (current-time-string)))
 354             (setq group-art (cdr group-art)))))))
 355
 356 (defun nnmbox-active-number (group)
 357   "Find the next article number in GROUP."
 358   (let ((active (car (cdr (assoc group nnmbox-group-alist)))))
 359     (setcdr active (1+ (cdr active)))
 360     (cdr active)))
 361
 362 (defun nnmbox-read-mbox ()
 363   (nnmbox-request-list)
 364   (setq nnmbox-group-alist (nnmail-get-active))
 365   (if (not (file-exists-p nnmbox-mbox-file))
 366       (write-region 1 1 nnmbox-mbox-file t 'nomesg))
 367   (if (and nnmbox-mbox-buffer
 368            (get-buffer nnmbox-mbox-buffer)
 369            (buffer-name nnmbox-mbox-buffer)
 370            (save-excursion
 371              (set-buffer nnmbox-mbox-buffer)
 372              (= (buffer-size) (nth 7 (file-attributes nnmbox-mbox-file)))))
 373       ()
 374     (save-excursion
 375       (let ((delim (concat "^" rmail-unix-mail-delimiter))
 376             start end)
 377         (set-buffer (setq nnmbox-mbox-buffer
 378                           (find-file-noselect nnmbox-mbox-file)))
 379         (buffer-disable-undo (current-buffer))
 380         (goto-char (point-min))
 381         (while (re-search-forward delim nil t)
 382           (setq start (match-beginning 0))
 383           (if (not (search-forward "\nX-Gnus-Newsgroup: "
 384                                    (save-excursion
 385                                      (setq end
 386                                            (or
 387                                             (and
 388                                              (re-search-forward delim nil t)
 389                                              (match-beginning 0))
 390                                             (point-max))))
 391                                    t))
 392               (save-excursion
 393                 (save-restriction
 394                   (narrow-to-region start end)
 395                   (nnmbox-save-mail))))
 396           (goto-char end))))))
 397
 398 (defun nnmbox-get-new-mail ()
 399   (let (incoming)
 400     (nnmbox-read-mbox)
 401     (if (and nnmail-spool-file
 402              (file-exists-p nnmail-spool-file)
 403              (> (nth 7 (file-attributes nnmail-spool-file)) 0))
 404         (progn
 405           (and gnus-verbose-backends
 406                (message "nnmbox: Reading incoming mail..."))
 407           (setq incoming
 408                 (nnmail-move-inbox nnmail-spool-file
 409                                    (concat nnmbox-mbox-file "-Incoming")))
 410           (save-excursion
 411             (let ((in-buf (nnmail-split-incoming
 412                            incoming 'nnmbox-save-mail t)))
 413               (set-buffer nnmbox-mbox-buffer)
 414               (goto-char (point-max))
 415               (insert-buffer-substring in-buf)
 416               (kill-buffer in-buf)))
 417           (run-hooks 'nnmail-read-incoming-hook)
 418           (and gnus-verbose-backends
 419                (message "nnmbox: Reading incoming mail...done"))))
 420     (and (buffer-modified-p nnmbox-mbox-buffer)
 421          (save-excursion
 422            (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
 423            (set-buffer nnmbox-mbox-buffer)
 424            (save-buffer)))
 425 ;    (if incoming
 426 ;       (delete-file incoming))
 427     ))
 428
 429 (provide 'nnmbox)
 430
 431 ;;; nnmbox.el ends here