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