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
  61 \f
  62
  63 (defvar nnmbox-current-server nil)
  64 (defvar nnmbox-server-alist nil)
  65 (defvar nnmbox-server-variables
  66   (list
  67    (list 'nnmbox-mbox-file nnmbox-mbox-file)
  68    (list 'nnmbox-active-file nnmbox-active-file)
  69    (list 'nnmbox-get-new-mail nnmbox-get-new-mail)
  70    '(nnmbox-current-group nil)
  71    '(nnmbox-status-string "")
  72    '(nnmbox-group-alist nil)))
  73
  74 \f
  75
  76 ;;; Interface functions
  77
  78 (defun nnmbox-retrieve-headers (sequence &optional newsgroup server)
  79   (save-excursion
  80     (set-buffer nntp-server-buffer)
  81     (erase-buffer)
  82     (let ((file nil)
  83           (number (length sequence))
  84           (count 0)
  85           beg 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                 (setq beg (point))
 107                 (insert-buffer-substring nnmbox-mbox-buffer start stop)
 108                 (goto-char (point-max))
 109                 (insert ".\n")))
 110           (setq sequence (cdr sequence))
 111           (setq count (1+ count))
 112           (and (numberp nnmail-large-newsgroup)
 113                (> number nnmail-large-newsgroup)
 114                (zerop (% count 20))
 115                gnus-verbose-backends
 116                (message "nnmbox: Receiving headers... %d%%"
 117                         (/ (* count 100) number))))
 118
 119         (and (numberp nnmail-large-newsgroup)
 120              (> number nnmail-large-newsgroup)
 121              gnus-verbose-backends
 122              (message "nnmbox: Receiving headers...done"))
 123
 124         ;; Fold continuation lines.
 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          article rest)
 237     (save-excursion
 238       (set-buffer nnmbox-mbox-buffer)
 239       (while articles
 240         (goto-char (point-min))
 241         (if (search-forward (nnmbox-article-string (car articles)) nil t)
 242             (if (or force
 243                     (> (nnmail-days-between
 244                         (current-time-string)
 245                         (buffer-substring
 246                          (point) (progn (end-of-line) (point))))
 247                        days))
 248                 (progn
 249                   (and gnus-verbose-backends
 250                        (message "Deleting: %s" (car articles)))
 251                   (nnmbox-delete-mail))
 252               (setq rest (cons (car articles) rest))))
 253         (setq articles (cdr articles)))
 254       (save-buffer)
 255       ;; Find the lowest active article in this group.
 256       (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist))))
 257         (goto-char (point-min))
 258         (while (and (not (search-forward
 259                           (nnmbox-article-string (car active)) nil t))
 260                     (<= (car active) (cdr active)))
 261           (setcar active (1+ (car active)))
 262           (goto-char (point-min))))
 263       (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
 264       rest)))
 265
 266 (defun nnmbox-request-move-article
 267   (article group server accept-form &optional last)
 268   (nnmbox-possibly-change-newsgroup group)
 269   (let ((buf (get-buffer-create " *nnmbox move*"))
 270         result)
 271     (and
 272      (nnmbox-request-article article group server)
 273      (save-excursion
 274        (set-buffer buf)
 275        (buffer-disable-undo (current-buffer))
 276        (erase-buffer)
 277        (insert-buffer-substring nntp-server-buffer)
 278        (goto-char (point-min))
 279        (while (re-search-forward
 280                "^X-Gnus-Newsgroup:"
 281                (save-excursion (search-forward "\n\n" nil t) (point)) t)
 282          (delete-region (progn (beginning-of-line) (point))
 283                         (progn (forward-line 1) (point))))
 284        (setq result (eval accept-form))
 285        (kill-buffer buf)
 286        result)
 287      (save-excursion
 288        (set-buffer nnmbox-mbox-buffer)
 289        (goto-char (point-min))
 290        (if (search-forward (nnmbox-article-string article) nil t)
 291            (nnmbox-delete-mail))
 292        (and last (save-buffer))))
 293     result))
 294
 295 (defun nnmbox-request-accept-article (group &optional last)
 296   (let ((buf (current-buffer))
 297         result beg)
 298     (goto-char (point-min))
 299     (if (looking-at "X-From-Line: ")
 300         (replace-match "From ")
 301       (insert "From nobody " (current-time-string) "\n"))
 302     (and
 303      (nnmbox-request-list)
 304      (setq nnmbox-group-alist (nnmail-get-active))
 305      (progn
 306        (set-buffer buf)
 307        (goto-char (point-min))
 308        (search-forward "\n\n" nil t)
 309        (forward-line -1)
 310        (while (re-search-backward "^X-Gnus-Newsgroup: " nil t)
 311          (delete-region (point) (progn (forward-line 1) (point))))
 312        (setq result (nnmbox-save-mail (and (stringp group) group))))
 313      (save-excursion
 314        (set-buffer nnmbox-mbox-buffer)
 315        (insert-buffer-substring buf)
 316        (and last (save-buffer))
 317        result)
 318      (nnmail-save-active nnmbox-group-alist nnmbox-active-file))
 319     (car result)))
 320
 321 (defun nnmbox-request-replace-article (article group buffer)
 322   (nnmbox-possibly-change-newsgroup group)
 323   (save-excursion
 324     (set-buffer nnmbox-mbox-buffer)
 325     (goto-char (point-min))
 326     (if (not (search-forward (nnmbox-article-string article) nil t))
 327         nil
 328       (nnmbox-delete-mail t t)
 329       (insert-buffer-substring buffer)
 330       (save-buffer)
 331       t)))
 332
 333 \f
 334 ;;; Internal functions.
 335
 336 ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
 337 ;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox
 338 ;; delimeter line.
 339 (defun nnmbox-delete-mail (&optional force leave-delim)
 340   ;; Delete the current X-Gnus-Newsgroup line.
 341   (or force
 342       (delete-region
 343        (progn (beginning-of-line) (point))
 344        (progn (forward-line 1) (point))))
 345   ;; Beginning of the article.
 346   (save-excursion
 347     (save-restriction
 348       (narrow-to-region
 349        (save-excursion
 350          (re-search-backward (concat "^" rmail-unix-mail-delimiter) nil t)
 351          (if leave-delim (progn (forward-line 1) (point))
 352            (match-beginning 0)))
 353        (progn
 354          (forward-line 1)
 355          (or (and (re-search-forward (concat "^" rmail-unix-mail-delimiter)
 356                                      nil t)
 357                   (if (and (not (bobp)) leave-delim)
 358                       (progn (forward-line -2) (point))
 359                     (match-beginning 0)))
 360              (point-max))))
 361       (goto-char (point-min))
 362       ;; Only delete the article if no other groups owns it as well.
 363       (if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
 364           (delete-region (point-min) (point-max))))))
 365
 366 (defun nnmbox-possibly-change-newsgroup (newsgroup)
 367   (if (or (not nnmbox-mbox-buffer)
 368           (not (buffer-name nnmbox-mbox-buffer)))
 369       (save-excursion
 370         (set-buffer (setq nnmbox-mbox-buffer
 371                           (find-file-noselect nnmbox-mbox-file)))
 372         (buffer-disable-undo (current-buffer))))
 373   (if (not nnmbox-group-alist)
 374       (progn
 375         (nnmbox-request-list)
 376         (setq nnmbox-group-alist (nnmail-get-active))))
 377   (if newsgroup
 378       (if (assoc newsgroup nnmbox-group-alist)
 379           (setq nnmbox-current-group newsgroup))))
 380
 381 (defun nnmbox-article-string (article)
 382   (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"
 383           (int-to-string article) " "))
 384
 385 (defun nnmbox-save-mail (&optional group)
 386   "Called narrowed to an article."
 387   (let* ((nnmail-split-methods
 388           (if group (list (list group "")) nnmail-split-methods))
 389          (group-art (nreverse (nnmail-article-group 'nnmbox-active-number))))
 390     (nnmail-insert-lines)
 391     (nnmail-insert-xref group-art)
 392     (nnmbox-insert-newsgroup-line group-art)
 393     (run-hooks 'nnml-prepare-save-mail-hook)
 394     group-art))
 395
 396 (defun nnmbox-insert-newsgroup-line (group-art)
 397   (save-excursion
 398     (goto-char (point-min))
 399     (if (search-forward "\n\n" nil t)
 400         (progn
 401           (forward-char -1)
 402           (while group-art
 403             (insert (format "X-Gnus-Newsgroup: %s:%d   %s\n"
 404                             (car (car group-art)) (cdr (car group-art))
 405                             (current-time-string)))
 406             (setq group-art (cdr group-art)))))
 407     t))
 408
 409 (defun nnmbox-active-number (group)
 410   "Find the next article number in GROUP."
 411   (let ((active (car (cdr (assoc group nnmbox-group-alist)))))
 412     (setcdr active (1+ (cdr active)))
 413     (cdr active)))
 414
 415 (defun nnmbox-read-mbox ()
 416   (nnmbox-request-list)
 417   (setq nnmbox-group-alist (nnmail-get-active))
 418   (if (not (file-exists-p nnmbox-mbox-file))
 419       (write-region 1 1 nnmbox-mbox-file t 'nomesg))
 420   (if (and nnmbox-mbox-buffer
 421            (buffer-name nnmbox-mbox-buffer)
 422            (save-excursion
 423              (set-buffer nnmbox-mbox-buffer)
 424              (= (buffer-size) (nth 7 (file-attributes nnmbox-mbox-file)))))
 425       ()
 426     (save-excursion
 427       (let ((delim (concat "^" rmail-unix-mail-delimiter))
 428             start end)
 429         (set-buffer (setq nnmbox-mbox-buffer
 430                           (find-file-noselect nnmbox-mbox-file)))
 431         (buffer-disable-undo (current-buffer))
 432         (goto-char (point-min))
 433         (while (re-search-forward delim nil t)
 434           (setq start (match-beginning 0))
 435           (if (not (search-forward "\nX-Gnus-Newsgroup: "
 436                                    (save-excursion
 437                                      (setq end
 438                                            (or
 439                                             (and
 440                                              (re-search-forward delim nil t)
 441                                              (match-beginning 0))
 442                                             (point-max))))
 443                                    t))
 444               (save-excursion
 445                 (save-restriction
 446                   (narrow-to-region start end)
 447                   (nnmbox-save-mail))))
 448           (goto-char end))))))
 449
 450 (defun nnmbox-get-new-mail (&optional group)
 451   "Read new incoming mail."
 452   (let* ((spools (nnmail-get-spool-files group))
 453          (all-spools spools)
 454          incoming incomings)
 455     (nnmbox-read-mbox)
 456     (if (or (not nnmbox-get-new-mail) (not nnmail-spool-file))
 457         ()
 458       ;; We go through all the existing spool files and split the
 459       ;; mail from each.
 460       (while spools
 461         (and
 462          (file-exists-p (car spools))
 463          (> (nth 7 (file-attributes (car spools))) 0)
 464          (progn
 465            (and gnus-verbose-backends
 466                 (message "nnmbox: Reading incoming mail..."))
 467            (setq incoming
 468                  (nnmail-move-inbox
 469                   (car spools) (concat nnmbox-mbox-file "-Incoming")))
 470            (save-excursion
 471              (setq group (nnmail-get-split-group (car spools) group))
 472              (let ((in-buf (nnmail-split-incoming
 473                             incoming 'nnmbox-save-mail t group)))
 474                (set-buffer nnmbox-mbox-buffer)
 475                (goto-char (point-max))
 476                (insert-buffer-substring in-buf)
 477                (kill-buffer in-buf)))))
 478         (setq spools (cdr spools)))
 479       ;; If we did indeed read any incoming spools, we save all info.
 480       (and (buffer-modified-p nnmbox-mbox-buffer)
 481            (save-excursion
 482              (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
 483              (set-buffer nnmbox-mbox-buffer)
 484              (save-buffer)))
 485       (if incomings (run-hooks 'nnmail-read-incoming-hook))
 486       (while incomings
 487         (and nnmail-delete-incoming
 488              (file-writable-p incoming)
 489              (delete-file incoming))
 490         (setq incomings (cdr incomings))))))
 491
 492
 493 (provide 'nnmbox)
 494
 495 ;;; nnmbox.el ends here