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