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

   1 ;;; nnfolder.el --- mail folder 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 ;; Various enhancements by byer@mv.us.adobe.com (Scott Byer).
  30
  31 ;;; Code:
  32
  33 (require 'nnheader)
  34 (require 'rmail)
  35 (require 'nnmail)
  36
  37 (defvar nnfolder-directory (expand-file-name "~/Mail/")
  38   "The name of the mail box file in the users home directory.")
  39
  40 (defvar nnfolder-active-file (concat nnfolder-directory  "active")
  41   "The name of the active file.")
  42
  43 (defvar nnfolder-newsgroups-file (concat nnfolder-directory "newsgroups")
  44   "Mail newsgroups description file.")
  45
  46 (defvar nnfolder-get-new-mail t
  47   "If non-nil, nnml will check the incoming mail file and split the mail.")
  48
  49 \f
  50
  51 (defconst nnfolder-version "nnfolder 0.1"
  52   "nnfolder version.")
  53
  54 (defconst nnfolder-article-marker "X-Gnus-Article-Number: "
  55   "String used to demarcate what the article number for a message is.")
  56
  57 (defvar nnfolder-current-group nil)
  58 (defvar nnfolder-current-buffer nil)
  59 (defvar nnfolder-status-string "")
  60 (defvar nnfolder-group-alist nil)
  61 (defvar nnfolder-buffer-alist nil)
  62
  63 (defmacro nnfolder-article-string (article)
  64   (` (concat "\n" nnfolder-article-marker (int-to-string (, article)) "")))
  65
  66 \f
  67
  68 (defvar nnfolder-current-server nil)
  69 (defvar nnfolder-server-alist nil)
  70 (defvar nnfolder-server-variables
  71   (list
  72    (list 'nnfolder-directory nnfolder-directory)
  73    (list 'nnfolder-active-file nnfolder-active-file)
  74    (list 'nnfolder-newsgroups-file nnfolder-newsgroups-file)
  75    (list 'nnfolder-get-new-mail nnfolder-get-new-mail)
  76    '(nnfolder-current-group nil)
  77    '(nnfolder-current-buffer nil)
  78    '(nnfolder-status-string "")
  79    '(nnfolder-group-alist nil)
  80    '(nnfolder-buffer-alist nil)))
  81
  82 \f
  83
  84 ;;; Interface functions
  85
  86 (defun nnfolder-retrieve-headers (sequence &optional newsgroup server)
  87   (save-excursion
  88     (set-buffer nntp-server-buffer)
  89     (erase-buffer)
  90     (let ((file nil)
  91           (number (length sequence))
  92           (delim-string (concat "^" rmail-unix-mail-delimiter))
  93           beg article art-string start stop)
  94       (nnfolder-possibly-change-group newsgroup)
  95       (while sequence
  96         (setq article (car sequence))
  97         (setq art-string (nnfolder-article-string article))
  98         (set-buffer nnfolder-current-buffer)
  99         (if (or (search-forward art-string nil t)
 100                 ;; Don't search the whole file twice!  Also, articles
 101                 ;; probably have some locality by number, so searching
 102                 ;; backwards will be faster.  Especially if we're at the
 103                 ;; beginning of the buffer :-). -SLB
 104                 (search-backward art-string nil t))
 105             (progn
 106               (setq start (or (re-search-backward delim-string nil t)
 107                               (point)))
 108               (search-forward "\n\n" nil t)
 109               (setq stop (1- (point)))
 110               (set-buffer nntp-server-buffer)
 111               (insert (format "221 %d Article retrieved.\n" article))
 112               (setq beg (point))
 113               (insert-buffer-substring nnfolder-current-buffer start stop)
 114               (goto-char (point-max))
 115               (insert ".\n")))
 116         (setq sequence (cdr sequence)))
 117
 118       ;; Fold continuation lines.
 119       (set-buffer nntp-server-buffer)
 120       (goto-char 1)
 121       (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
 122         (replace-match " " t t))
 123       'headers)))
 124
 125 (defun nnfolder-open-server (server &optional defs)
 126   (nnheader-init-server-buffer)
 127   (if (equal server nnfolder-current-server)
 128       t
 129     (if nnfolder-current-server
 130         (setq nnfolder-server-alist
 131               (cons (list nnfolder-current-server
 132                           (nnheader-save-variables nnfolder-server-variables))
 133                     nnfolder-server-alist)))
 134     (let ((state (assoc server nnfolder-server-alist)))
 135       (if state
 136           (progn
 137             (nnheader-restore-variables (nth 1 state))
 138             (setq nnfolder-server-alist (delq state nnfolder-server-alist)))
 139         (nnheader-set-init-variables nnfolder-server-variables defs)))
 140     (setq nnfolder-current-server server)))
 141
 142 (defun nnfolder-close-server (&optional server)
 143   t)
 144
 145 (defun nnfolder-server-opened (&optional server)
 146   (equal server nnfolder-current-server))
 147
 148 (defun nnfolder-request-close ()
 149   (let ((alist nnfolder-buffer-alist))
 150     (while alist
 151       (nnfolder-close-group (car (car alist)))
 152       (setq alist (cdr alist))))
 153   (setq nnfolder-buffer-alist nil
 154         nnfolder-group-alist nil))
 155
 156 (defun nnfolder-status-message (&optional server)
 157   nnfolder-status-string)
 158
 159 (defun nnfolder-request-article (article &optional newsgroup server buffer)
 160   (nnfolder-possibly-change-group newsgroup)
 161   (if (stringp article)
 162       nil
 163     (save-excursion
 164       (set-buffer nnfolder-current-buffer)
 165       (goto-char 1)
 166       (if (search-forward (nnfolder-article-string article) nil t)
 167           (let (start stop)
 168             (re-search-backward (concat "^" rmail-unix-mail-delimiter) nil t)
 169             (setq start (point))
 170             (forward-line 1)
 171             (or (and (re-search-forward
 172                       (concat "^" rmail-unix-mail-delimiter) nil t)
 173                      (forward-line -1))
 174                 (goto-char (point-max)))
 175             (setq stop (point))
 176             (let ((nntp-server-buffer (or buffer nntp-server-buffer)))
 177               (set-buffer nntp-server-buffer)
 178               (erase-buffer)
 179               (insert-buffer-substring nnfolder-current-buffer start stop)
 180               (goto-char (point-min))
 181               (while (looking-at "From ")
 182                 (delete-char 5)
 183                 (insert "X-From-Line: ")
 184                 (forward-line 1))
 185               t))))))
 186
 187 (defun nnfolder-request-group (group &optional server dont-check)
 188   (save-excursion
 189     (nnfolder-possibly-change-group group)
 190     (and (assoc group nnfolder-group-alist)
 191          (save-excursion
 192            (set-buffer nntp-server-buffer)
 193            (erase-buffer)
 194            (if dont-check
 195                t
 196              (nnfolder-get-new-mail)
 197              (let ((active (assoc group nnfolder-group-alist)))
 198                ;; I've been getting stray 211 lines in my nnfolder active
 199                ;; file.  So, let's make sure that doesn't happen. -SLB
 200                (set-buffer nntp-server-buffer)
 201                (insert (format "211 %d %d %d %s\n"
 202                                (1+ (- (cdr (car (cdr active)))
 203                                       (car (car (cdr active)))))
 204                                (car (car (cdr active)))
 205                                (cdr (car (cdr active)))
 206                                (car active))))
 207              t)))))
 208
 209 (defun nnfolder-close-group (group &optional server)
 210   (nnfolder-possibly-change-group group)
 211   (save-excursion
 212     (set-buffer nnfolder-current-buffer)
 213     (or (buffer-modified-p)
 214         (kill-buffer (current-buffer))))
 215   (setq nnfolder-buffer-alist (delq (assoc group nnfolder-buffer-alist)
 216                                     nnfolder-buffer-alist))
 217   (setq nnfolder-current-group nil
 218         nnfolder-current-buffer nil)
 219   t)
 220
 221 (defun nnfolder-request-list (&optional server)
 222   (if server (nnfolder-get-new-mail))
 223   (or nnfolder-group-alist
 224       (nnmail-find-file nnfolder-active-file)
 225       (progn
 226         (setq nnfolder-group-alist (nnmail-get-active))
 227         (nnmail-save-active nnfolder-group-alist nnfolder-active-file)
 228         (nnmail-find-file nnfolder-active-file))))
 229
 230 (defun nnfolder-request-newgroups (date &optional server)
 231   (nnfolder-request-list server))
 232
 233 (defun nnfolder-request-list-newsgroups (&optional server)
 234   (nnmail-find-file nnfolder-newsgroups-file))
 235
 236 (defun nnfolder-request-post (&optional server)
 237   (mail-send-and-exit nil))
 238
 239 (fset 'nnfolder-request-post-buffer 'nnmail-request-post-buffer)
 240
 241 (defun nnfolder-request-expire-articles (articles newsgroup &optional server force)
 242   (nnfolder-possibly-change-group newsgroup)
 243   (let* ((days (or (and nnmail-expiry-wait-function
 244                         (funcall nnmail-expiry-wait-function newsgroup))
 245                    nnmail-expiry-wait))
 246          article rest)
 247     (save-excursion
 248       (set-buffer nnfolder-current-buffer)
 249       (while articles
 250         (goto-char 1)
 251         (if (search-forward (nnfolder-article-string (car articles)) nil t)
 252             (if (or force
 253                     (> (nnmail-days-between
 254                         (current-time-string)
 255                         (buffer-substring
 256                          (point) (progn (end-of-line) (point))))
 257                        days))
 258                 (progn
 259                   (and gnus-verbose-backends
 260                        (message "Deleting: %s" (car articles)))
 261                   (nnfolder-delete-mail))
 262               (setq rest (cons (car articles) rest))))
 263         (setq articles (cdr articles)))
 264       (save-buffer)
 265       ;; Find the lowest active article in this group.
 266       (let ((active (nth 1 (assoc newsgroup nnfolder-group-alist))))
 267         (goto-char (point-min))
 268         (while (not (search-forward
 269                      (nnfolder-article-string (car active)) nil t))
 270           (setcar active (1+ (car active)))
 271           (goto-char (point-min))))
 272       (nnmail-save-active nnfolder-group-alist nnfolder-active-file)
 273       rest)))
 274
 275 (defun nnfolder-request-move-article
 276   (article group server accept-form &optional last)
 277   (nnfolder-possibly-change-group group)
 278   (let ((buf (get-buffer-create " *nnfolder move*"))
 279         result)
 280     (and
 281      (nnfolder-request-article article group server)
 282      (save-excursion
 283        (set-buffer buf)
 284        (buffer-disable-undo (current-buffer))
 285        (erase-buffer)
 286        (insert-buffer-substring nntp-server-buffer)
 287        (goto-char (point-min))
 288        (while (re-search-forward
 289                "^X-Gnus-Newsgroup:"
 290                (save-excursion (search-forward "\n\n" nil t) (point)) t)
 291          (delete-region (progn (beginning-of-line) (point))
 292                         (progn (forward-line 1) (point))))
 293        (setq result (eval accept-form))
 294        (kill-buffer buf)
 295        result)
 296      (save-excursion
 297        (nnfolder-possibly-change-group group)
 298        (set-buffer nnfolder-current-buffer)
 299        (goto-char 1)
 300        (if (search-forward (nnfolder-article-string article) nil t)
 301            (nnfolder-delete-mail))
 302        (and last (save-buffer))))
 303     result))
 304
 305 (defun nnfolder-request-accept-article (group &optional last)
 306   (nnfolder-possibly-change-group group)
 307   (let ((buf (current-buffer))
 308         result beg)
 309     (goto-char (point-min))
 310     (if (looking-at "X-From-Line: ")
 311         (replace-match "From ")
 312       (insert "From nobody " (current-time-string) "\n"))
 313     (and
 314      (nnfolder-request-list)
 315      (setq nnfolder-group-alist (nnmail-get-active))
 316      (progn
 317        (set-buffer buf)
 318        (goto-char (point-min))
 319        (search-forward "\n\n" nil t)
 320        (forward-line -1)
 321        (while (re-search-backward "^X-Gnus-Newsgroup: " nil t)
 322          (delete-region (point) (progn (forward-line 1) (point))))
 323        (setq result (nnfolder-save-mail (and (stringp group) group))))
 324      (save-excursion
 325        (set-buffer nnfolder-current-buffer)
 326        (insert-buffer-substring buf)
 327        (and last (save-buffer))
 328        result)
 329      (nnmail-save-active nnfolder-group-alist nnfolder-active-file))
 330     (car result)))
 331
 332 (defun nnfolder-request-replace-article (article group buffer)
 333   (nnfolder-possibly-change-group group)
 334   (save-excursion
 335     (set-buffer nnfolder-current-buffer)
 336     (goto-char 1)
 337     (if (not (search-forward (nnfolder-article-string article) nil t))
 338         nil
 339       (nnfolder-delete-mail t t)
 340       (insert-buffer-substring buffer)
 341       (save-buffer)
 342       t)))
 343
 344 \f
 345 ;;; Internal functions.
 346
 347 (defun nnfolder-delete-mail (&optional force leave-delim)
 348   ;; Beginning of the article.
 349   (save-excursion
 350     (save-restriction
 351       (narrow-to-region
 352        (save-excursion
 353          (re-search-backward (concat "^" rmail-unix-mail-delimiter) nil t)
 354          (if leave-delim (progn (forward-line 1) (point))
 355            (match-beginning 0)))
 356        (progn
 357          (forward-line 1)
 358          (or (and (re-search-forward (concat "^" rmail-unix-mail-delimiter)
 359                                      nil t)
 360                   (if (and (not (bobp)) leave-delim)
 361                       (progn (forward-line -2) (point))
 362                     (match-beginning 0)))
 363              (point-max))))
 364       (delete-region (point-min) (point-max)))))
 365
 366 (defun nnfolder-possibly-change-group (group)
 367   (or (file-exists-p nnfolder-directory)
 368       (make-directory (directory-file-name nnfolder-directory)))
 369   (if (not nnfolder-group-alist)
 370       (progn
 371         (nnfolder-request-list)
 372         (setq nnfolder-group-alist (nnmail-get-active))))
 373   (or (assoc group nnfolder-group-alist)
 374       (not (file-exists-p (concat nnfolder-directory group)))
 375       (progn
 376         (setq nnfolder-group-alist
 377               (cons (list group (cons 1 0)) nnfolder-group-alist))
 378         (nnmail-save-active nnfolder-group-alist nnfolder-active-file)))
 379   (let (inf file)
 380     (if (and (equal group nnfolder-current-group)
 381              (buffer-name nnfolder-current-buffer))
 382         ()
 383       (if (setq inf (member group nnfolder-buffer-alist))
 384           (setq nnfolder-current-buffer (nth 1 inf)))
 385       (setq nnfolder-current-group group)
 386       (if (not (buffer-name nnfolder-current-buffer))
 387           (progn
 388             (setq nnfolder-buffer-alist (delq inf nnfolder-buffer-alist))
 389             (setq inf nil)))
 390       (if inf
 391           ()
 392         (save-excursion
 393           (setq file (concat nnfolder-directory group))
 394           (if (not (file-exists-p file))
 395               (write-region 1 1 file t 'nomesg))
 396           (set-buffer (nnfolder-read-folder file))
 397           (setq nnfolder-buffer-alist (cons (list group (current-buffer))
 398                                             nnfolder-buffer-alist))))))
 399   (setq nnfolder-current-group group))
 400
 401 (defun nnfolder-save-mail (&optional group)
 402   "Called narrowed to an article."
 403   (let* ((nnmail-split-methods
 404           (if group (list (list group "")) nnmail-split-methods))
 405          (group-art-list
 406           (nreverse (nnmail-article-group 'nnfolder-active-number)))
 407          group-art)
 408     (nnmail-insert-lines)
 409     (nnmail-insert-xref group-art-list)
 410     (while group-art-list
 411       (setq group-art (car group-art-list)
 412             group-art-list (cdr group-art-list))
 413       (nnfolder-possibly-change-group (car group-art))
 414       (nnfolder-insert-newsgroup-line group-art)
 415       (let ((beg (point-min))
 416             (end (point-max))
 417             (obuf (current-buffer)))
 418         (save-excursion
 419           (set-buffer nnfolder-current-buffer)
 420           (goto-char (point-max))
 421           (insert-buffer-substring obuf beg end)))
 422       (goto-char (point-min))
 423       (search-forward (concat "\n" nnfolder-article-marker))
 424       (delete-region (progn (beginning-of-line) (point))
 425                      (progn (forward-line 1) (point))))))
 426
 427 (defun nnfolder-insert-newsgroup-line (group-art)
 428   (save-excursion
 429     (goto-char (point-min))
 430     (if (search-forward "\n\n" nil t)
 431         (progn
 432           (forward-char -1)
 433           (insert (format (concat nnfolder-article-marker "%d   %s\n")
 434                           (cdr group-art) (current-time-string)))))))
 435
 436 (defun nnfolder-active-number (group)
 437   (if (not nnfolder-group-alist)
 438       (save-excursion
 439         (nnfolder-request-list)
 440         (setq nnfolder-group-alist (nnmail-get-active))))
 441   (let ((active (car (cdr (assoc group nnfolder-group-alist)))))
 442     (setcdr active (1+ (cdr active)))
 443     (cdr active)))
 444
 445
 446 ;; This method has a problem if you've accidentally let the active list get
 447 ;; out of sync with the files.  This could happen, say, if you've
 448 ;; accidentally gotten new mail with something other than (ding) (but why
 449 ;; would _that_ ever happen? :-).  In that case, we will be in the middle of
 450 ;; processing the file, ready to add new X-Gnus article number markers, and
 451 ;; we'll run accross a message with no ID yet - the active list _may_not_ be
 452 ;; ready for us yet.
 453
 454 ;; To handle this, I'm modifying this routine to maintain the maximum ID seen
 455 ;; so far, and when we hit a message with no ID, we will _manually_ scan the
 456 ;; rest of the message looking for any more, possibly higher IDs.  We'll
 457 ;; assume the maximum that we find is the highest active.  Note that this
 458 ;; shouldn't cost us much extra time at all, but will be a lot less
 459 ;; vulnerable to glitches between the mbox and the active file.
 460
 461 (defun nnfolder-read-folder (file)
 462   (save-excursion
 463     (if (not nnfolder-group-alist)
 464         (progn
 465           (nnfolder-request-list)
 466           (setq nnfolder-group-alist (nnmail-get-active))))
 467     ;; We should be paranoid here and make sure the group is in the alist,
 468     ;; and add it if it isn't.
 469     ;;(if (not (assoc nnfoler-current-group nnfolder-group-alist)
 470     (set-buffer (setq nnfolder-current-buffer (find-file-noselect file)))
 471     (buffer-disable-undo (current-buffer))
 472     (let ((delim (concat "^" rmail-unix-mail-delimiter))
 473           (marker (concat "\n" nnfolder-article-marker))
 474           (number "[0-9]+")
 475           (active (car (cdr (assoc nnfolder-current-group
 476                                    nnfolder-group-alist))))
 477           activenumber start end)
 478       (goto-char (point-min))
 479       ;;
 480       ;; Anytime the active number is 1 or 0, it is supect.  In that case,
 481       ;; search the file manually to find the active number.
 482       (setq activenumber (cdr active))
 483       (if (< activenumber 2)
 484           (progn
 485             (while (and (search-forward marker nil t)
 486                         (re-search-forward number nil t))
 487               (setq activenumber (max activenumber
 488                                       (string-to-number (buffer-substring
 489                                                          (match-beginning 0)
 490                                                          (match-end 0))))))
 491             (goto-char (point-min))))
 492
 493       ;; Keep track of the active number on our own, and insert it back into
 494       ;; the active list when we're done. Also, prime the pump to cut down on
 495       ;; the number of searches we do.
 496       (setq end (or (and (re-search-forward delim nil t)
 497                          (match-beginning 0))
 498                     (point-max)))
 499       (while (not (= end (point-max)))
 500         (setq start end)
 501         (goto-char end)
 502         (end-of-line)
 503         (setq end (or (and (re-search-forward delim nil t)
 504                            (match-beginning 0))
 505                       (point-max)))
 506         (goto-char start)
 507         (if (not (search-forward marker end t))
 508             (progn
 509               (narrow-to-region start end)
 510               (nnmail-insert-lines)
 511               (setq activenumber (1+ activenumber))
 512               (nnfolder-insert-newsgroup-line (cons nil activenumber))
 513               (widen))))
 514
 515       ;; Make absolutely sure that the active list reflects reality!
 516       (setcdr active activenumber)
 517       (nnmail-save-active nnfolder-group-alist nnfolder-active-file)
 518       (current-buffer))))
 519
 520 (defun nnfolder-get-new-mail ()
 521   (let (incoming)
 522     (if (and nnmail-spool-file
 523              nnfolder-get-new-mail
 524              (file-exists-p nnmail-spool-file)
 525              (> (nth 7 (file-attributes nnmail-spool-file)) 0))
 526         (progn
 527           (and gnus-verbose-backends
 528                (message "nnfolder: Reading incoming mail..."))
 529           (setq incoming
 530                 (nnmail-move-inbox nnmail-spool-file
 531                                    (concat nnfolder-directory "Incoming")))
 532           (nnmail-split-incoming incoming 'nnfolder-save-mail)
 533           (run-hooks 'nnmail-read-incoming-hook)
 534           (nnmail-save-active nnfolder-group-alist nnfolder-active-file)
 535           (and gnus-verbose-backends
 536                (message "nnfolder: Reading incoming mail...done"))))
 537     (let ((bufs nnfolder-buffer-alist))
 538       (save-excursion
 539         (while bufs
 540           (if (not (buffer-name (nth 1 (car bufs))))
 541               (setq nnfolder-buffer-alist
 542                     (delq (car bufs) nnfolder-buffer-alist))
 543             (set-buffer (nth 1 (car bufs)))
 544             (and (buffer-modified-p)
 545                  (save-buffer)))
 546           (setq bufs (cdr bufs)))))
 547     ;; (if incoming (delete-file incoming))
 548     ))
 549
 550 (provide 'nnfolder)
 551
 552 ;;; nnfolder.el ends here