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 " *nnmbox mbox buffer*")
  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        nntp-server-buffer
 153        (buffer-name nntp-server-buffer)))
 154
 155 (defun nnmbox-status-message (&optional server)
 156   nnmbox-status-string)
 157
 158 (defun nnmbox-request-article (article &optional newsgroup server buffer)
 159   (nnmbox-possibly-change-newsgroup newsgroup)
 160   (if (stringp article)
 161       nil
 162     (save-excursion
 163       (set-buffer nnmbox-mbox-buffer)
 164       (goto-char (point-min))
 165       (if (search-forward (nnmbox-article-string article) nil t)
 166           (let (start stop)
 167             (re-search-backward (concat "^" rmail-unix-mail-delimiter) nil t)
 168             (setq start (point))
 169             (forward-line 1)
 170             (or (and (re-search-forward
 171                       (concat "^" rmail-unix-mail-delimiter) nil t)
 172                      (forward-line -1))
 173                 (goto-char (point-max)))
 174             (setq stop (point))
 175             (let ((nntp-server-buffer (or buffer nntp-server-buffer)))
 176               (set-buffer nntp-server-buffer)
 177               (erase-buffer)
 178               (insert-buffer-substring nnmbox-mbox-buffer start stop)
 179               (goto-char (point-min))
 180               (while (looking-at "From ")
 181                 (delete-char 5)
 182                 (insert "X-From-Line: ")
 183                 (forward-line 1))
 184               t))))))
 185
 186 (defun nnmbox-request-group (group &optional server dont-check)
 187   (save-excursion
 188     (if (nnmbox-possibly-change-newsgroup group)
 189         (if dont-check
 190             t
 191           (nnmbox-get-new-mail group)
 192           (save-excursion
 193             (set-buffer nntp-server-buffer)
 194             (erase-buffer)
 195             (let ((active (assoc group nnmbox-group-alist)))
 196               (insert (format "211 %d %d %d %s\n"
 197                               (1+ (- (cdr (car (cdr active)))
 198                                      (car (car (cdr active)))))
 199                               (car (car (cdr active)))
 200                               (cdr (car (cdr active)))
 201                               (car active))))
 202             t)))))
 203
 204 (defun nnmbox-close-group (group &optional server)
 205   t)
 206
 207 (defun nnmbox-request-list (&optional server)
 208   (if server (nnmbox-get-new-mail))
 209   (save-excursion
 210     (or (nnmail-find-file nnmbox-active-file)
 211         (progn
 212           (setq nnmbox-group-alist (nnmail-get-active))
 213           (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
 214           (nnmail-find-file nnmbox-active-file)))))
 215
 216 (defun nnmbox-request-newgroups (date &optional server)
 217   (nnmbox-request-list server))
 218
 219 (defun nnmbox-request-list-newsgroups (&optional server)
 220   (setq nnmbox-status-string "nnmbox: LIST NEWSGROUPS is not implemented.")
 221   nil)
 222
 223 (defun nnmbox-request-post (&optional server)
 224   (mail-send-and-exit nil))
 225
 226 (defalias 'nnmbox-request-post-buffer 'nnmail-request-post-buffer)
 227
 228 (defun nnmbox-request-expire-articles
 229   (articles newsgroup &optional server force)
 230   (nnmbox-possibly-change-newsgroup newsgroup)
 231   (let* ((days (or (and nnmail-expiry-wait-function
 232                         (funcall nnmail-expiry-wait-function newsgroup))
 233                    nnmail-expiry-wait))
 234          article rest)
 235     (save-excursion
 236       (set-buffer nnmbox-mbox-buffer)
 237       (while articles
 238         (goto-char (point-min))
 239         (if (search-forward (nnmbox-article-string (car articles)) nil t)
 240             (if (or force
 241                     (> (nnmail-days-between
 242                         (current-time-string)
 243                         (buffer-substring
 244                          (point) (progn (end-of-line) (point))))
 245                        days))
 246                 (progn
 247                   (and gnus-verbose-backends
 248                        (message "Deleting: %s" (car articles)))
 249                   (nnmbox-delete-mail))
 250               (setq rest (cons (car articles) rest))))
 251         (setq articles (cdr articles)))
 252       (save-buffer)
 253       ;; Find the lowest active article in this group.
 254       (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist))))
 255         (goto-char (point-min))
 256         (while (and (not (search-forward
 257                           (nnmbox-article-string (car active)) nil t))
 258                     (<= (car active) (cdr active)))
 259           (setcar active (1+ (car active)))
 260           (goto-char (point-min))))
 261       (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
 262       rest)))
 263
 264 (defun nnmbox-request-move-article
 265   (article group server accept-form &optional last)
 266   (nnmbox-possibly-change-newsgroup group)
 267   (let ((buf (get-buffer-create " *nnmbox move*"))
 268         result)
 269     (and
 270      (nnmbox-request-article article group server)
 271      (save-excursion
 272        (set-buffer buf)
 273        (buffer-disable-undo (current-buffer))
 274        (erase-buffer)
 275        (insert-buffer-substring nntp-server-buffer)
 276        (goto-char (point-min))
 277        (while (re-search-forward
 278                "^X-Gnus-Newsgroup:"
 279                (save-excursion (search-forward "\n\n" nil t) (point)) t)
 280          (delete-region (progn (beginning-of-line) (point))
 281                         (progn (forward-line 1) (point))))
 282        (setq result (eval accept-form))
 283        (kill-buffer buf)
 284        result)
 285      (save-excursion
 286        (set-buffer nnmbox-mbox-buffer)
 287        (goto-char (point-min))
 288        (if (search-forward (nnmbox-article-string article) nil t)
 289            (nnmbox-delete-mail))
 290        (and last (save-buffer))))
 291     result))
 292
 293 (defun nnmbox-request-accept-article (group &optional last)
 294   (let ((buf (current-buffer))
 295         result beg)
 296     (goto-char (point-min))
 297     (if (looking-at "X-From-Line: ")
 298         (replace-match "From ")
 299       (insert "From nobody " (current-time-string) "\n"))
 300     (and
 301      (nnmbox-request-list)
 302      (setq nnmbox-group-alist (nnmail-get-active))
 303      (progn
 304        (set-buffer buf)
 305        (goto-char (point-min))
 306        (search-forward "\n\n" nil t)
 307        (forward-line -1)
 308        (while (re-search-backward "^X-Gnus-Newsgroup: " nil t)
 309          (delete-region (point) (progn (forward-line 1) (point))))
 310        (setq result (nnmbox-save-mail (and (stringp group) group))))
 311      (save-excursion
 312        (set-buffer nnmbox-mbox-buffer)
 313        (insert-buffer-substring buf)
 314        (and last (save-buffer))
 315        result)
 316      (nnmail-save-active nnmbox-group-alist nnmbox-active-file))
 317     (car result)))
 318
 319 (defun nnmbox-request-replace-article (article group buffer)
 320   (nnmbox-possibly-change-newsgroup group)
 321   (save-excursion
 322     (set-buffer nnmbox-mbox-buffer)
 323     (goto-char (point-min))
 324     (if (not (search-forward (nnmbox-article-string article) nil t))
 325         nil
 326       (nnmbox-delete-mail t t)
 327       (insert-buffer-substring buffer)
 328       (save-buffer)
 329       t)))
 330
 331 \f
 332 ;;; Internal functions.
 333
 334 ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
 335 ;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox
 336 ;; delimeter line.
 337 (defun nnmbox-delete-mail (&optional force leave-delim)
 338   ;; Delete the current X-Gnus-Newsgroup line.
 339   (or force
 340       (delete-region
 341        (progn (beginning-of-line) (point))
 342        (progn (forward-line 1) (point))))
 343   ;; Beginning of the article.
 344   (save-excursion
 345     (save-restriction
 346       (narrow-to-region
 347        (save-excursion
 348          (re-search-backward (concat "^" rmail-unix-mail-delimiter) nil t)
 349          (if leave-delim (progn (forward-line 1) (point))
 350            (match-beginning 0)))
 351        (progn
 352          (forward-line 1)
 353          (or (and (re-search-forward (concat "^" rmail-unix-mail-delimiter)
 354                                      nil t)
 355                   (if (and (not (bobp)) leave-delim)
 356                       (progn (forward-line -2) (point))
 357                     (match-beginning 0)))
 358              (point-max))))
 359       (goto-char (point-min))
 360       ;; Only delete the article if no other groups owns it as well.
 361       (if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
 362           (delete-region (point-min) (point-max))))))
 363
 364 (defun nnmbox-possibly-change-newsgroup (newsgroup)
 365   (if (not (get-buffer nnmbox-mbox-buffer))
 366       (save-excursion
 367         (set-buffer (setq nnmbox-mbox-buffer
 368                           (find-file-noselect nnmbox-mbox-file)))
 369         (buffer-disable-undo (current-buffer))))
 370   (if (not nnmbox-group-alist)
 371       (progn
 372         (nnmbox-request-list)
 373         (setq nnmbox-group-alist (nnmail-get-active))))
 374   (if newsgroup
 375       (if (assoc newsgroup nnmbox-group-alist)
 376           (setq nnmbox-current-group newsgroup))))
 377
 378 (defun nnmbox-article-string (article)
 379   (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"
 380           (int-to-string article) " "))
 381
 382 (defun nnmbox-save-mail (&optional group)
 383   "Called narrowed to an article."
 384   (let* ((nnmail-split-methods
 385           (if group (list (list group "")) nnmail-split-methods))
 386          (group-art (nreverse (nnmail-article-group 'nnmbox-active-number))))
 387     (nnmail-insert-lines)
 388     (nnmail-insert-xref group-art)
 389     (nnmbox-insert-newsgroup-line group-art)
 390     (run-hooks 'nnml-prepare-save-mail-hook)
 391     group-art))
 392
 393 (defun nnmbox-insert-newsgroup-line (group-art)
 394   (save-excursion
 395     (goto-char (point-min))
 396     (if (search-forward "\n\n" nil t)
 397         (progn
 398           (forward-char -1)
 399           (while group-art
 400             (insert (format "X-Gnus-Newsgroup: %s:%d   %s\n"
 401                             (car (car group-art)) (cdr (car group-art))
 402                             (current-time-string)))
 403             (setq group-art (cdr group-art)))))
 404     t))
 405
 406 (defun nnmbox-active-number (group)
 407   "Find the next article number in GROUP."
 408   (let ((active (car (cdr (assoc group nnmbox-group-alist)))))
 409     (setcdr active (1+ (cdr active)))
 410     (cdr active)))
 411
 412 (defun nnmbox-read-mbox ()
 413   (nnmbox-request-list)
 414   (setq nnmbox-group-alist (nnmail-get-active))
 415   (if (not (file-exists-p nnmbox-mbox-file))
 416       (write-region 1 1 nnmbox-mbox-file t 'nomesg))
 417   (if (and nnmbox-mbox-buffer
 418            (get-buffer nnmbox-mbox-buffer)
 419            (buffer-name nnmbox-mbox-buffer)
 420            (save-excursion
 421              (set-buffer nnmbox-mbox-buffer)
 422              (= (buffer-size) (nth 7 (file-attributes nnmbox-mbox-file)))))
 423       ()
 424     (save-excursion
 425       (let ((delim (concat "^" rmail-unix-mail-delimiter))
 426             start end)
 427         (set-buffer (setq nnmbox-mbox-buffer
 428                           (find-file-noselect nnmbox-mbox-file)))
 429         (buffer-disable-undo (current-buffer))
 430         (goto-char (point-min))
 431         (while (re-search-forward delim nil t)
 432           (setq start (match-beginning 0))
 433           (if (not (search-forward "\nX-Gnus-Newsgroup: "
 434                                    (save-excursion
 435                                      (setq end
 436                                            (or
 437                                             (and
 438                                              (re-search-forward delim nil t)
 439                                              (match-beginning 0))
 440                                             (point-max))))
 441                                    t))
 442               (save-excursion
 443                 (save-restriction
 444                   (narrow-to-region start end)
 445                   (nnmbox-save-mail))))
 446           (goto-char end))))))
 447
 448 (defun nnmbox-get-new-mail (&optional group)
 449   "Read new incoming mail."
 450   (let ((spools (nnmail-get-spool-files group))
 451         incoming incomings)
 452     (nnmbox-read-mbox)
 453     (if (or (not nnmbox-get-new-mail) (not nnmail-spool-file))
 454         ()
 455       ;; We go through all the existing spool files and split the
 456       ;; mail from each.
 457       (while spools
 458         (and
 459          (file-exists-p (car spools))
 460          (> (nth 7 (file-attributes (car spools))) 0)
 461          (progn
 462            (and gnus-verbose-backends
 463                 (message "nnmbox: Reading incoming mail..."))
 464            (setq incoming
 465                  (nnmail-move-inbox
 466                   (car spools) (concat nnmbox-mbox-file "-Incoming")))
 467            (save-excursion
 468              (let ((in-buf (nnmail-split-incoming
 469                             incoming 'nnmbox-save-mail t group)))
 470                (set-buffer nnmbox-mbox-buffer)
 471                (goto-char (point-max))
 472                (insert-buffer-substring in-buf)
 473                (kill-buffer in-buf)))))
 474         (setq spools (cdr spools)))
 475       ;; If we did indeed read any incoming spools, we save all info.
 476       (and (buffer-modified-p nnmbox-mbox-buffer)
 477            (save-excursion
 478              (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
 479              (set-buffer nnmbox-mbox-buffer)
 480              (save-buffer)))
 481       (while incomings
 482         ;; The following has been commented away, just to make sure
 483         ;; that nobody ever loses any mail. If you feel safe that
 484         ;; nnfolder will never do anything strange, just remove those
 485         ;; two semicolons, and avoid having lots of "Incoming*"
 486         ;; files.
 487         ;; (and (file-writable-p incoming) (delete-file incoming))
 488         (setq incomings (cdr incomings))))))
 489
 490
 491 (provide 'nnmbox)
 492
 493 ;;; nnmbox.el ends here