cgit.sxemacs.org Git - gnus/blob - lisp/nnmbox.el

   1 ;;; nnmbox.el --- mail mbox access for Gnus
   2 ;; Copyright (C) 1995,96,97,98 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   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 ;; You should have received a copy of the GNU General Public License
  16 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  17 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  18 ;; Boston, MA 02111-1307, USA.
  19
  20 ;;; Commentary:
  21
  22 ;; For an overview of what the interface functions do, please see the
  23 ;; Gnus sources.
  24
  25 ;;; Code:
  26
  27 (require 'nnheader)
  28 (require 'message)
  29 (require 'nnmail)
  30 (require 'nnoo)
  31 (eval-when-compile (require 'cl))
  32
  33 (nnoo-declare nnmbox)
  34
  35 (defvoo nnmbox-mbox-file (expand-file-name "~/mbox")
  36   "The name of the mail box file in the user's home directory.")
  37
  38 (defvoo nnmbox-active-file (expand-file-name "~/.mbox-active")
  39   "The name of the active file for the mail box.")
  40
  41 (defvoo nnmbox-get-new-mail t
  42   "If non-nil, nnmbox will check the incoming mail file and split the mail.")
  43
  44 (defvoo nnmbox-prepare-save-mail-hook nil
  45   "Hook run narrowed to an article before saving.")
  46
  47 \f
  48
  49 (defconst nnmbox-version "nnmbox 1.0"
  50   "nnmbox version.")
  51
  52 (defvoo nnmbox-current-group nil
  53   "Current nnmbox news group directory.")
  54
  55 (defconst nnmbox-mbox-buffer nil)
  56
  57 (defvoo nnmbox-status-string "")
  58
  59 (defvoo nnmbox-group-alist nil)
  60 (defvoo nnmbox-active-timestamp nil)
  61
  62 \f
  63
  64 ;;; Interface functions
  65
  66 (nnoo-define-basics nnmbox)
  67
  68 (deffoo nnmbox-retrieve-headers (sequence &optional newsgroup server fetch-old)
  69   (save-excursion
  70     (set-buffer nntp-server-buffer)
  71     (erase-buffer)
  72     (let ((number (length sequence))
  73           (count 0)
  74           article art-string start stop)
  75       (nnmbox-possibly-change-newsgroup newsgroup server)
  76       (while sequence
  77         (setq article (car sequence))
  78         (setq art-string (nnmbox-article-string article))
  79         (set-buffer nnmbox-mbox-buffer)
  80         (when (or (search-forward art-string nil t)
  81                   (progn (goto-char (point-min))
  82                          (search-forward art-string nil t)))
  83           (setq start
  84                 (save-excursion
  85                   (re-search-backward
  86                    (concat "^" message-unix-mail-delimiter) nil t)
  87                   (point)))
  88           (search-forward "\n\n" nil t)
  89           (setq stop (1- (point)))
  90           (set-buffer nntp-server-buffer)
  91           (insert (format "221 %d Article retrieved.\n" article))
  92           (insert-buffer-substring nnmbox-mbox-buffer start stop)
  93           (goto-char (point-max))
  94           (insert ".\n"))
  95         (setq sequence (cdr sequence))
  96         (setq count (1+ count))
  97         (and (numberp nnmail-large-newsgroup)
  98              (> number nnmail-large-newsgroup)
  99              (zerop (% count 20))
 100              (nnheader-message 5 "nnmbox: Receiving headers... %d%%"
 101                                (/ (* count 100) number))))
 102
 103       (and (numberp nnmail-large-newsgroup)
 104            (> number nnmail-large-newsgroup)
 105            (nnheader-message 5 "nnmbox: Receiving headers...done"))
 106
 107       (set-buffer nntp-server-buffer)
 108       (nnheader-fold-continuation-lines)
 109       'headers)))
 110
 111 (deffoo nnmbox-open-server (server &optional defs)
 112   (nnoo-change-server 'nnmbox server defs)
 113   (nnmbox-create-mbox)
 114   (cond
 115    ((not (file-exists-p nnmbox-mbox-file))
 116     (nnmbox-close-server)
 117     (nnheader-report 'nnmbox "No such file: %s" nnmbox-mbox-file))
 118    ((file-directory-p nnmbox-mbox-file)
 119     (nnmbox-close-server)
 120     (nnheader-report 'nnmbox "Not a regular file: %s" nnmbox-mbox-file))
 121    (t
 122     (nnheader-report 'nnmbox "Opened server %s using mbox %s" server
 123                      nnmbox-mbox-file)
 124     t)))
 125
 126 (deffoo nnmbox-close-server (&optional server)
 127   (when (and nnmbox-mbox-buffer
 128              (buffer-name nnmbox-mbox-buffer))
 129     (kill-buffer nnmbox-mbox-buffer))
 130   (nnoo-close-server 'nnmbox server)
 131   t)
 132
 133 (deffoo nnmbox-server-opened (&optional server)
 134   (and (nnoo-current-server-p 'nnmbox server)
 135        nnmbox-mbox-buffer
 136        (buffer-name nnmbox-mbox-buffer)
 137        nntp-server-buffer
 138        (buffer-name nntp-server-buffer)))
 139
 140 (deffoo nnmbox-request-article (article &optional newsgroup server buffer)
 141   (nnmbox-possibly-change-newsgroup newsgroup server)
 142   (save-excursion
 143     (set-buffer nnmbox-mbox-buffer)
 144     (goto-char (point-min))
 145     (when (search-forward (nnmbox-article-string article) nil t)
 146       (let (start stop)
 147         (re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
 148         (setq start (point))
 149         (forward-line 1)
 150         (or (and (re-search-forward
 151                   (concat "^" message-unix-mail-delimiter) nil t)
 152                  (forward-line -1))
 153             (goto-char (point-max)))
 154         (setq stop (point))
 155         (let ((nntp-server-buffer (or buffer nntp-server-buffer)))
 156           (set-buffer nntp-server-buffer)
 157           (erase-buffer)
 158           (insert-buffer-substring nnmbox-mbox-buffer start stop)
 159           (goto-char (point-min))
 160           (while (looking-at "From ")
 161             (delete-char 5)
 162             (insert "X-From-Line: ")
 163             (forward-line 1))
 164           (if (numberp article)
 165               (cons nnmbox-current-group article)
 166             (nnmbox-article-group-number)))))))
 167
 168 (deffoo nnmbox-request-group (group &optional server dont-check)
 169   (nnmbox-possibly-change-newsgroup nil server)
 170   (let ((active (cadr (assoc group nnmbox-group-alist))))
 171     (cond
 172      ((or (null active)
 173           (null (nnmbox-possibly-change-newsgroup group server)))
 174       (nnheader-report 'nnmbox "No such group: %s" group))
 175      (dont-check
 176       (nnheader-report 'nnmbox "Selected group %s" group)
 177       (nnheader-insert ""))
 178      (t
 179       (nnheader-report 'nnmbox "Selected group %s" group)
 180       (nnheader-insert "211 %d %d %d %s\n"
 181                        (1+ (- (cdr active) (car active)))
 182                        (car active) (cdr active) group)))))
 183
 184 (deffoo nnmbox-request-scan (&optional group server)
 185   (nnmbox-possibly-change-newsgroup group server)
 186   (nnmbox-read-mbox)
 187   (nnmail-get-new-mail
 188    'nnmbox
 189    (lambda ()
 190      (save-excursion
 191        (set-buffer nnmbox-mbox-buffer)
 192        (save-buffer)))
 193    (file-name-directory nnmbox-mbox-file)
 194    group
 195    (lambda ()
 196      (save-excursion
 197        (let ((in-buf (current-buffer)))
 198          (set-buffer nnmbox-mbox-buffer)
 199          (goto-char (point-max))
 200          (insert-buffer-substring in-buf)))
 201      (nnmail-save-active nnmbox-group-alist nnmbox-active-file))))
 202
 203 (deffoo nnmbox-close-group (group &optional server)
 204   t)
 205
 206 (deffoo nnmbox-request-create-group (group &optional server args)
 207   (nnmail-activate 'nnmbox)
 208   (unless (assoc group nnmbox-group-alist)
 209     (push (list group (cons 1 0))
 210           nnmbox-group-alist)
 211     (nnmail-save-active nnmbox-group-alist nnmbox-active-file))
 212   t)
 213
 214 (deffoo nnmbox-request-list (&optional server)
 215   (save-excursion
 216     (nnmail-find-file nnmbox-active-file)
 217     (setq nnmbox-group-alist (nnmail-get-active))
 218     t))
 219
 220 (deffoo nnmbox-request-newgroups (date &optional server)
 221   (nnmbox-request-list server))
 222
 223 (deffoo nnmbox-request-list-newsgroups (&optional server)
 224   (nnheader-report 'nnmbox "LIST NEWSGROUPS is not implemented."))
 225
 226 (deffoo nnmbox-request-expire-articles
 227   (articles newsgroup &optional server force)
 228   (nnmbox-possibly-change-newsgroup newsgroup server)
 229   (let* ((is-old t)
 230          rest)
 231     (nnmail-activate 'nnmbox)
 232
 233     (save-excursion
 234       (set-buffer nnmbox-mbox-buffer)
 235       (while (and articles is-old)
 236         (goto-char (point-min))
 237         (when (search-forward (nnmbox-article-string (car articles)) nil t)
 238           (if (setq is-old
 239                     (nnmail-expired-article-p
 240                      newsgroup
 241                      (buffer-substring
 242                       (point) (progn (end-of-line) (point))) force))
 243               (progn
 244                 (nnheader-message 5 "Deleting article %d in %s..."
 245                                   (car articles) newsgroup)
 246                 (nnmbox-delete-mail))
 247             (push (car articles) rest)))
 248         (setq articles (cdr articles)))
 249       (save-buffer)
 250       ;; Find the lowest active article in this group.
 251       (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist))))
 252         (goto-char (point-min))
 253         (while (and (not (search-forward
 254                           (nnmbox-article-string (car active)) nil t))
 255                     (<= (car active) (cdr active)))
 256           (setcar active (1+ (car active)))
 257           (goto-char (point-min))))
 258       (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
 259       (nconc rest articles))))
 260
 261 (deffoo nnmbox-request-move-article
 262   (article group server accept-form &optional last)
 263   (let ((buf (get-buffer-create " *nnmbox move*"))
 264         result)
 265     (and
 266      (nnmbox-request-article article group server)
 267      (save-excursion
 268        (set-buffer buf)
 269        (erase-buffer)
 270        (insert-buffer-substring nntp-server-buffer)
 271        (goto-char (point-min))
 272        (while (re-search-forward
 273                "^X-Gnus-Newsgroup:"
 274                (save-excursion (search-forward "\n\n" nil t) (point)) t)
 275          (delete-region (progn (beginning-of-line) (point))
 276                         (progn (forward-line 1) (point))))
 277        (setq result (eval accept-form))
 278        (kill-buffer buf)
 279        result)
 280      (save-excursion
 281        (nnmbox-possibly-change-newsgroup group server)
 282        (set-buffer nnmbox-mbox-buffer)
 283        (goto-char (point-min))
 284        (when (search-forward (nnmbox-article-string article) nil t)
 285          (nnmbox-delete-mail))
 286        (and last (save-buffer))))
 287     result))
 288
 289 (deffoo nnmbox-request-accept-article (group &optional server last)
 290   (nnmbox-possibly-change-newsgroup group server)
 291   (nnmail-check-syntax)
 292   (let ((buf (current-buffer))
 293         result)
 294     (goto-char (point-min))
 295     ;; The From line may have been quoted by movemail.
 296     (when (looking-at (concat ">" message-unix-mail-delimiter))
 297       (delete-char 1))
 298     (if (looking-at "X-From-Line: ")
 299         (replace-match "From ")
 300       (insert "From nobody " (current-time-string) "\n"))
 301     (and
 302      (nnmail-activate 'nnmbox)
 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        (when nnmail-cache-accepted-message-ids
 311          (nnmail-cache-insert (nnmail-fetch-field "message-id")))
 312        (setq result (if (stringp group)
 313                         (list (cons group (nnmbox-active-number group)))
 314                       (nnmail-article-group 'nnmbox-active-number)))
 315        (if (and (null result)
 316                 (yes-or-no-p "Moved to `junk' group; delete article? "))
 317            (setq result 'junk)
 318          (setq result (car (nnmbox-save-mail result)))))
 319      (save-excursion
 320        (set-buffer nnmbox-mbox-buffer)
 321        (goto-char (point-max))
 322        (insert-buffer-substring buf)
 323        (when last
 324          (when nnmail-cache-accepted-message-ids
 325            (nnmail-cache-close))
 326          (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
 327          (save-buffer))))
 328     result))
 329
 330 (deffoo nnmbox-request-replace-article (article group buffer)
 331   (nnmbox-possibly-change-newsgroup group)
 332   (save-excursion
 333     (set-buffer nnmbox-mbox-buffer)
 334     (goto-char (point-min))
 335     (if (not (search-forward (nnmbox-article-string article) nil t))
 336         nil
 337       (nnmbox-delete-mail t t)
 338       (insert-buffer-substring buffer)
 339       (save-buffer)
 340       t)))
 341
 342 (deffoo nnmbox-request-delete-group (group &optional force server)
 343   (nnmbox-possibly-change-newsgroup group server)
 344   ;; Delete all articles in GROUP.
 345   (if (not force)
 346       ()                                ; Don't delete the articles.
 347     (save-excursion
 348       (set-buffer nnmbox-mbox-buffer)
 349       (goto-char (point-min))
 350       ;; Delete all articles in this group.
 351       (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"))
 352             found)
 353         (while (search-forward ident nil t)
 354           (setq found t)
 355           (nnmbox-delete-mail))
 356         (when found
 357           (save-buffer)))))
 358   ;; Remove the group from all structures.
 359   (setq nnmbox-group-alist
 360         (delq (assoc group nnmbox-group-alist) nnmbox-group-alist)
 361         nnmbox-current-group nil)
 362   ;; Save the active file.
 363   (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
 364   t)
 365
 366 (deffoo nnmbox-request-rename-group (group new-name &optional server)
 367   (nnmbox-possibly-change-newsgroup group server)
 368   (save-excursion
 369     (set-buffer nnmbox-mbox-buffer)
 370     (goto-char (point-min))
 371     (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"))
 372           (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":"))
 373           found)
 374       (while (search-forward ident nil t)
 375         (replace-match new-ident t t)
 376         (setq found t))
 377       (when found
 378         (save-buffer))))
 379   (let ((entry (assoc group nnmbox-group-alist)))
 380     (when entry
 381       (setcar entry new-name))
 382     (setq nnmbox-current-group nil)
 383     ;; Save the new group alist.
 384     (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
 385     t))
 386
 387 \f
 388 ;;; Internal functions.
 389
 390 ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
 391 ;; headers there are.  If LEAVE-DELIM, don't delete the Unix mbox
 392 ;; delimiter line.
 393 (defun nnmbox-delete-mail (&optional force leave-delim)
 394   ;; Delete the current X-Gnus-Newsgroup line.
 395   (or force
 396       (delete-region
 397        (progn (beginning-of-line) (point))
 398        (progn (forward-line 1) (point))))
 399   ;; Beginning of the article.
 400   (save-excursion
 401     (save-restriction
 402       (narrow-to-region
 403        (save-excursion
 404          (re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
 405          (if leave-delim (progn (forward-line 1) (point))
 406            (match-beginning 0)))
 407        (progn
 408          (forward-line 1)
 409          (or (and (re-search-forward (concat "^" message-unix-mail-delimiter)
 410                                      nil t)
 411                   (if (and (not (bobp)) leave-delim)
 412                       (progn (forward-line -2) (point))
 413                     (match-beginning 0)))
 414              (point-max))))
 415       (goto-char (point-min))
 416       ;; Only delete the article if no other groups owns it as well.
 417       (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
 418         (delete-region (point-min) (point-max))))))
 419
 420 (defun nnmbox-possibly-change-newsgroup (newsgroup &optional server)
 421   (when (and server
 422              (not (nnmbox-server-opened server)))
 423     (nnmbox-open-server server))
 424   (when (or (not nnmbox-mbox-buffer)
 425             (not (buffer-name nnmbox-mbox-buffer)))
 426     (save-excursion
 427       (set-buffer (setq nnmbox-mbox-buffer
 428                         (nnheader-find-file-noselect
 429                          nnmbox-mbox-file nil 'raw)))
 430       (mm-enable-multibyte)
 431       (buffer-disable-undo)))
 432   (when (not nnmbox-group-alist)
 433     (nnmail-activate 'nnmbox))
 434   (if newsgroup
 435       (when (assoc newsgroup nnmbox-group-alist)
 436         (setq nnmbox-current-group newsgroup))
 437     t))
 438
 439 (defun nnmbox-article-string (article)
 440   (if (numberp article)
 441       (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"
 442               (int-to-string article) " ")
 443     (concat "\nMessage-ID: " article)))
 444
 445 (defun nnmbox-article-group-number ()
 446   (save-excursion
 447     (goto-char (point-min))
 448     (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
 449                              nil t)
 450       (cons (buffer-substring (match-beginning 1) (match-end 1))
 451             (string-to-int
 452              (buffer-substring (match-beginning 2) (match-end 2)))))))
 453
 454 (defun nnmbox-save-mail (group-art)
 455   "Called narrowed to an article."
 456   (let ((delim (concat "^" message-unix-mail-delimiter)))
 457     (goto-char (point-min))
 458     ;; This might come from somewhere else.
 459     (unless (looking-at delim)
 460       (insert "From nobody " (current-time-string) "\n")
 461       (goto-char (point-min)))
 462     ;; Quote all "From " lines in the article.
 463     (forward-line 1)
 464     (while (re-search-forward delim nil t)
 465       (beginning-of-line)
 466       (insert "> "))
 467     (nnmail-insert-lines)
 468     (nnmail-insert-xref group-art)
 469     (nnmbox-insert-newsgroup-line group-art)
 470     (run-hooks 'nnmail-prepare-save-mail-hook)
 471     (run-hooks 'nnmbox-prepare-save-mail-hook)
 472     group-art))
 473
 474 (defun nnmbox-insert-newsgroup-line (group-art)
 475   (save-excursion
 476     (goto-char (point-min))
 477     (when (search-forward "\n\n" nil t)
 478       (forward-char -1)
 479       (while group-art
 480         (insert (format "X-Gnus-Newsgroup: %s:%d   %s\n"
 481                         (caar group-art) (cdar group-art)
 482                         (current-time-string)))
 483         (setq group-art (cdr group-art))))
 484     t))
 485
 486 (defun nnmbox-active-number (group)
 487   ;; Find the next article number in GROUP.
 488   (let ((active (cadr (assoc group nnmbox-group-alist))))
 489     (if active
 490         (setcdr active (1+ (cdr active)))
 491       ;; This group is new, so we create a new entry for it.
 492       ;; This might be a bit naughty... creating groups on the drop of
 493       ;; a hat, but I don't know...
 494       (push (list group (setq active (cons 1 1)))
 495             nnmbox-group-alist))
 496     (cdr active)))
 497
 498 (defun nnmbox-create-mbox ()
 499   (when (not (file-exists-p nnmbox-mbox-file))
 500     (nnmail-write-region 1 1 nnmbox-mbox-file t 'nomesg)))
 501
 502 (defun nnmbox-read-mbox ()
 503   (nnmail-activate 'nnmbox)
 504   (nnmbox-create-mbox)
 505   (if (and nnmbox-mbox-buffer
 506            (buffer-name nnmbox-mbox-buffer)
 507            (save-excursion
 508              (set-buffer nnmbox-mbox-buffer)
 509              (= (buffer-size) (nnheader-file-size nnmbox-mbox-file))))
 510       ()
 511     (save-excursion
 512       (let ((delim (concat "^" message-unix-mail-delimiter))
 513             (alist nnmbox-group-alist)
 514             start end number)
 515         (set-buffer (setq nnmbox-mbox-buffer
 516                           (nnheader-find-file-noselect
 517                            nnmbox-mbox-file nil 'raw)))
 518         (mm-enable-multibyte)
 519         (buffer-disable-undo)
 520
 521         ;; Go through the group alist and compare against
 522         ;; the mbox file.
 523         (while alist
 524           (goto-char (point-max))
 525           (when (and (re-search-backward
 526                       (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) "
 527                               (caar alist)) nil t)
 528                      (>= (setq number
 529                                (string-to-number
 530                                 (buffer-substring
 531                                  (match-beginning 1) (match-end 1))))
 532                          (cdadar alist)))
 533             (setcdr (cadar alist) (1+ number)))
 534           (setq alist (cdr alist)))
 535
 536         (goto-char (point-min))
 537         (while (re-search-forward delim nil t)
 538           (setq start (match-beginning 0))
 539           (when (not (search-forward "\nX-Gnus-Newsgroup: "
 540                                      (save-excursion
 541                                        (setq end
 542                                              (or
 543                                               (and
 544                                                (re-search-forward delim nil t)
 545                                                (match-beginning 0))
 546                                               (point-max))))
 547                                      t))
 548             (save-excursion
 549               (save-restriction
 550                 (narrow-to-region start end)
 551                 (nnmbox-save-mail
 552                  (nnmail-article-group 'nnmbox-active-number)))))
 553           (goto-char end))))))
 554
 555 (provide 'nnmbox)
 556
 557 ;;; nnmbox.el ends here