git.chise.org Git - elisp/gnus.git-/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   (let ((active (cadr (assoc group nnmbox-group-alist))))
 170     (cond
 171      ((or (null active)
 172           (null (nnmbox-possibly-change-newsgroup group server)))
 173       (nnheader-report 'nnmbox "No such group: %s" group))
 174      (dont-check
 175       (nnheader-report 'nnmbox "Selected group %s" group)
 176       (nnheader-insert ""))
 177      (t
 178       (nnheader-report 'nnmbox "Selected group %s" group)
 179       (nnheader-insert "211 %d %d %d %s\n"
 180                        (1+ (- (cdr active) (car active)))
 181                        (car active) (cdr active) group)))))
 182
 183 (deffoo nnmbox-request-scan (&optional group server)
 184   (nnmbox-possibly-change-newsgroup group server)
 185   (nnmbox-read-mbox)
 186   (nnmail-get-new-mail
 187    'nnmbox
 188    (lambda ()
 189      (save-excursion
 190        (set-buffer nnmbox-mbox-buffer)
 191        (save-buffer)))
 192    (file-name-directory nnmbox-mbox-file)
 193    group
 194    (lambda ()
 195      (save-excursion
 196        (let ((in-buf (current-buffer)))
 197          (set-buffer nnmbox-mbox-buffer)
 198          (goto-char (point-max))
 199          (insert-buffer-substring in-buf)))
 200      (nnmail-save-active nnmbox-group-alist nnmbox-active-file))))
 201
 202 (deffoo nnmbox-close-group (group &optional server)
 203   t)
 204
 205 (deffoo nnmbox-request-create-group (group &optional server args)
 206   (nnmail-activate 'nnmbox)
 207   (unless (assoc group nnmbox-group-alist)
 208     (push (list group (cons 1 0))
 209           nnmbox-group-alist)
 210     (nnmail-save-active nnmbox-group-alist nnmbox-active-file))
 211   t)
 212
 213 (deffoo nnmbox-request-list (&optional server)
 214   (save-excursion
 215     (nnmail-find-file nnmbox-active-file)
 216     (setq nnmbox-group-alist (nnmail-get-active))
 217     t))
 218
 219 (deffoo nnmbox-request-newgroups (date &optional server)
 220   (nnmbox-request-list server))
 221
 222 (deffoo nnmbox-request-list-newsgroups (&optional server)
 223   (nnheader-report 'nnmbox "LIST NEWSGROUPS is not implemented."))
 224
 225 (deffoo nnmbox-request-expire-articles
 226   (articles newsgroup &optional server force)
 227   (nnmbox-possibly-change-newsgroup newsgroup server)
 228   (let* ((is-old t)
 229          rest)
 230     (nnmail-activate 'nnmbox)
 231
 232     (save-excursion
 233       (set-buffer nnmbox-mbox-buffer)
 234       (while (and articles is-old)
 235         (goto-char (point-min))
 236         (when (search-forward (nnmbox-article-string (car articles)) nil t)
 237           (if (setq is-old
 238                     (nnmail-expired-article-p
 239                      newsgroup
 240                      (buffer-substring
 241                       (point) (progn (end-of-line) (point))) force))
 242               (progn
 243                 (nnheader-message 5 "Deleting article %d in %s..."
 244                                   (car articles) newsgroup)
 245                 (nnmbox-delete-mail))
 246             (push (car articles) rest)))
 247         (setq articles (cdr articles)))
 248       (save-buffer)
 249       ;; Find the lowest active article in this group.
 250       (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist))))
 251         (goto-char (point-min))
 252         (while (and (not (search-forward
 253                           (nnmbox-article-string (car active)) nil t))
 254                     (<= (car active) (cdr active)))
 255           (setcar active (1+ (car active)))
 256           (goto-char (point-min))))
 257       (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
 258       (nconc rest articles))))
 259
 260 (deffoo nnmbox-request-move-article
 261   (article group server accept-form &optional last)
 262   (let ((buf (get-buffer-create " *nnmbox move*"))
 263         result)
 264     (and
 265      (nnmbox-request-article article group server)
 266      (save-excursion
 267        (set-buffer buf)
 268        (buffer-disable-undo (current-buffer))
 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       (buffer-disable-undo (current-buffer))))
 431   (when (not nnmbox-group-alist)
 432     (nnmail-activate 'nnmbox))
 433   (if newsgroup
 434       (when (assoc newsgroup nnmbox-group-alist)
 435         (setq nnmbox-current-group newsgroup))
 436     t))
 437
 438 (defun nnmbox-article-string (article)
 439   (if (numberp article)
 440       (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"
 441               (int-to-string article) " ")
 442     (concat "\nMessage-ID: " article)))
 443
 444 (defun nnmbox-article-group-number ()
 445   (save-excursion
 446     (goto-char (point-min))
 447     (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
 448                              nil t)
 449       (cons (buffer-substring (match-beginning 1) (match-end 1))
 450             (string-to-int
 451              (buffer-substring (match-beginning 2) (match-end 2)))))))
 452
 453 (defun nnmbox-save-mail (group-art)
 454   "Called narrowed to an article."
 455   (let ((delim (concat "^" message-unix-mail-delimiter)))
 456     (goto-char (point-min))
 457     ;; This might come from somewhere else.
 458     (unless (looking-at delim)
 459       (insert "From nobody " (current-time-string) "\n")
 460       (goto-char (point-min)))
 461     ;; Quote all "From " lines in the article.
 462     (forward-line 1)
 463     (while (re-search-forward delim nil t)
 464       (beginning-of-line)
 465       (insert "> "))
 466     (nnmail-insert-lines)
 467     (nnmail-insert-xref group-art)
 468     (nnmbox-insert-newsgroup-line group-art)
 469     (run-hooks 'nnmail-prepare-save-mail-hook)
 470     (run-hooks 'nnmbox-prepare-save-mail-hook)
 471     group-art))
 472
 473 (defun nnmbox-insert-newsgroup-line (group-art)
 474   (save-excursion
 475     (goto-char (point-min))
 476     (when (search-forward "\n\n" nil t)
 477       (forward-char -1)
 478       (while group-art
 479         (insert (format "X-Gnus-Newsgroup: %s:%d   %s\n"
 480                         (caar group-art) (cdar group-art)
 481                         (current-time-string)))
 482         (setq group-art (cdr group-art))))
 483     t))
 484
 485 (defun nnmbox-active-number (group)
 486   ;; Find the next article number in GROUP.
 487   (let ((active (cadr (assoc group nnmbox-group-alist))))
 488     (if active
 489         (setcdr active (1+ (cdr active)))
 490       ;; This group is new, so we create a new entry for it.
 491       ;; This might be a bit naughty... creating groups on the drop of
 492       ;; a hat, but I don't know...
 493       (push (list group (setq active (cons 1 1)))
 494             nnmbox-group-alist))
 495     (cdr active)))
 496
 497 (defun nnmbox-create-mbox ()
 498   (when (not (file-exists-p nnmbox-mbox-file))
 499     (nnmail-write-region 1 1 nnmbox-mbox-file t 'nomesg)))
 500
 501 (defun nnmbox-read-mbox ()
 502   (nnmail-activate 'nnmbox)
 503   (nnmbox-create-mbox)
 504   (if (and nnmbox-mbox-buffer
 505            (buffer-name nnmbox-mbox-buffer)
 506            (save-excursion
 507              (set-buffer nnmbox-mbox-buffer)
 508              (= (buffer-size) (nnheader-file-size nnmbox-mbox-file))))
 509       ()
 510     (save-excursion
 511       (let ((delim (concat "^" message-unix-mail-delimiter))
 512             (alist nnmbox-group-alist)
 513             start end number)
 514         (set-buffer (setq nnmbox-mbox-buffer
 515                           (nnheader-find-file-noselect
 516                            nnmbox-mbox-file nil 'raw)))
 517         (buffer-disable-undo (current-buffer))
 518
 519         ;; Go through the group alist and compare against
 520         ;; the mbox file.
 521         (while alist
 522           (goto-char (point-max))
 523           (when (and (re-search-backward
 524                       (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) "
 525                               (caar alist)) nil t)
 526                      (>= (setq number
 527                                (string-to-number
 528                                 (buffer-substring
 529                                  (match-beginning 1) (match-end 1))))
 530                          (cdadar alist)))
 531             (setcdr (cadar alist) (1+ number)))
 532           (setq alist (cdr alist)))
 533
 534         (goto-char (point-min))
 535         (while (re-search-forward delim nil t)
 536           (setq start (match-beginning 0))
 537           (when (not (search-forward "\nX-Gnus-Newsgroup: "
 538                                      (save-excursion
 539                                        (setq end
 540                                              (or
 541                                               (and
 542                                                (re-search-forward delim nil t)
 543                                                (match-beginning 0))
 544                                               (point-max))))
 545                                      t))
 546             (save-excursion
 547               (save-restriction
 548                 (narrow-to-region start end)
 549                 (nnmbox-save-mail
 550                  (nnmail-article-group 'nnmbox-active-number)))))
 551           (goto-char end))))))
 552
 553 (provide 'nnmbox)
 554
 555 ;;; nnmbox.el ends here