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