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))))