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 ((number (length sequence))
  83           (count 0)
  84           article art-string start stop)
  85       (nnmbox-possibly-change-newsgroup newsgroup)
  86       (if (stringp (car sequence))
  87           'headers
  88         (while sequence
  89           (setq article (car sequence))
  90           (setq art-string (nnmbox-article-string article))
  91           (set-buffer nnmbox-mbox-buffer)
  92           (if (or (search-forward art-string nil t)
  93                   (progn (goto-char (point-min))
  94                          (search-forward art-string nil t)))
  95               (progn
  96                 (setq start
  97                       (save-excursion
  98                         (re-search-backward
  99                          (concat "^" rmail-unix-mail-delimiter) nil t)
 100                         (point)))
 101                 (search-forward "\n\n" nil t)
 102                 (setq stop (1- (point)))
 103                 (set-buffer nntp-server-buffer)
 104                 (insert (format "221 %d Article retrieved.\n" article))
 105                 (insert-buffer-substring nnmbox-mbox-buffer start stop)
 106                 (goto-char (point-max))
 107                 (insert ".\n")))
 108           (setq sequence (cdr sequence))
 109           (setq count (1+ count))
 110           (and (numberp nnmail-large-newsgroup)
 111                (> number nnmail-large-newsgroup)
 112                (zerop (% count 20))
 113                gnus-verbose-backends
 114                (message "nnmbox: Receiving headers... %d%%"
 115                         (/ (* count 100) number))))
 116
 117         (and (numberp nnmail-large-newsgroup)
 118              (> number nnmail-large-newsgroup)
 119              gnus-verbose-backends
 120              (message "nnmbox: Receiving headers...done"))
 121
 122         ;; Fold continuation lines.
 123         (goto-char (point-min))
 124         (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
 125           (replace-match " " t t))
 126         'headers))))
 127
 128 (defun nnmbox-open-server (server &optional defs)
 129   (nnheader-init-server-buffer)
 130   (if (equal server nnmbox-current-server)
 131       t
 132     (if nnmbox-current-server
 133         (setq nnmbox-server-alist
 134               (cons (list nnmbox-current-server
 135                           (nnheader-save-variables nnmbox-server-variables))
 136                     nnmbox-server-alist)))
 137     (let ((state (assoc server nnmbox-server-alist)))
 138       (if state
 139           (progn
 140             (nnheader-restore-variables (nth 1 state))
 141             (setq nnmbox-server-alist (delq state nnmbox-server-alist)))
 142         (nnheader-set-init-variables nnmbox-server-variables defs)))
 143     (setq nnmbox-current-server server)))
 144
 145 (defun nnmbox-close-server (&optional server)
 146   t)
 147
 148 (defun nnmbox-server-opened (&optional server)
 149   (and (equal server nnmbox-current-server)
 150        nnmbox-mbox-buffer
 151        (buffer-name nnmbox-mbox-buffer)
 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          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)
 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 (or (not nnmbox-mbox-buffer)
 366           (not (buffer-name nnmbox-mbox-buffer)))
 367       (save-excursion
 368         (set-buffer (setq nnmbox-mbox-buffer
 369                           (find-file-noselect nnmbox-mbox-file)))
 370         (buffer-disable-undo (current-buffer))))
 371   (if (not nnmbox-group-alist)
 372       (progn
 373         (nnmbox-request-list)
 374         (setq nnmbox-group-alist (nnmail-get-active))))
 375   (if newsgroup
 376       (if (assoc newsgroup nnmbox-group-alist)
 377           (setq nnmbox-current-group newsgroup))))
 378
 379 (defun nnmbox-article-string (article)
 380   (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"
 381           (int-to-string article) " "))
 382
 383 (defun nnmbox-save-mail (&optional group)
 384   "Called narrowed to an article."
 385   (let* ((nnmail-split-methods
 386           (if group (list (list group "")) nnmail-split-methods))
 387          (group-art (nreverse (nnmail-article-group 'nnmbox-active-number))))
 388     (nnmail-insert-lines)
 389     (nnmail-insert-xref group-art)
 390     (nnmbox-insert-newsgroup-line group-art)
 391     (run-hooks 'nnml-prepare-save-mail-hook)
 392     group-art))
 393
 394 (defun nnmbox-insert-newsgroup-line (group-art)
 395   (save-excursion
 396     (goto-char (point-min))
 397     (if (search-forward "\n\n" nil t)
 398         (progn
 399           (forward-char -1)
 400           (while group-art
 401             (insert (format "X-Gnus-Newsgroup: %s:%d   %s\n"
 402                             (car (car group-art)) (cdr (car group-art))
 403                             (current-time-string)))
 404             (setq group-art (cdr group-art)))))
 405     t))
 406
 407 (defun nnmbox-active-number (group)
 408   "Find the next article number in GROUP."
 409   (let ((active (car (cdr (assoc group nnmbox-group-alist)))))
 410     (setcdr active (1+ (cdr active)))
 411     (cdr active)))
 412
 413 (defun nnmbox-read-mbox ()
 414   (nnmbox-request-list)
 415   (setq nnmbox-group-alist (nnmail-get-active))
 416   (if (not (file-exists-p nnmbox-mbox-file))
 417       (write-region 1 1 nnmbox-mbox-file t 'nomesg))
 418   (if (and 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          (group-in group)
 452          incoming incomings)
 453     (nnmbox-read-mbox)
 454     (if (or (not nnmbox-get-new-mail) (not nnmail-spool-file))
 455         ()
 456       ;; We go through all the existing spool files and split the
 457       ;; mail from each.
 458       (while spools
 459         (and
 460          (file-exists-p (car spools))
 461          (> (nth 7 (file-attributes (car spools))) 0)
 462          (progn
 463            (and gnus-verbose-backends
 464                 (message "nnmbox: Reading incoming mail..."))
 465            (setq incoming
 466                  (nnmail-move-inbox
 467                   (car spools) (concat nnmbox-mbox-file "-Incoming")))
 468            (save-excursion
 469              (setq group (nnmail-get-split-group (car spools) group-in))
 470              (let ((in-buf (nnmail-split-incoming
 471                             incoming 'nnmbox-save-mail t group)))
 472                (set-buffer nnmbox-mbox-buffer)
 473                (goto-char (point-max))
 474                (insert-buffer-substring in-buf)
 475                (kill-buffer in-buf)))))
 476         (setq spools (cdr spools)))
 477       ;; If we did indeed read any incoming spools, we save all info.
 478       (and (buffer-modified-p nnmbox-mbox-buffer)
 479            (save-excursion
 480              (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
 481              (set-buffer nnmbox-mbox-buffer)
 482              (save-buffer)))
 483       (if incomings (run-hooks 'nnmail-read-incoming-hook))
 484       (while incomings
 485         (and nnmail-delete-incoming
 486              (file-writable-p incoming)
 487              (delete-file incoming))
 488         (setq incomings (cdr incomings))))))
 489
 490
 491 (provide 'nnmbox)
 492
 493 ;;; nnmbox.el ends here