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