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

   1 ;;; nnmh.el --- mhspool access for Gnus
   2
   3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003
   4 ;;      Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;;      Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
   8 ;; Keywords: news, mail
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>.
  30 ;; For an overview of what the interface functions do, please see the
  31 ;; Gnus sources.
  32
  33 ;;; Code:
  34
  35 (require 'nnheader)
  36 (require 'nnmail)
  37 (require 'gnus-start)
  38 (require 'nnoo)
  39 (eval-when-compile (require 'cl))
  40
  41 (nnoo-declare nnmh)
  42
  43 (defvoo nnmh-directory message-directory
  44   "Mail spool directory.")
  45
  46 (defvoo nnmh-get-new-mail t
  47   "If non-nil, nnmh will check the incoming mail file and split the mail.")
  48
  49 (defvoo nnmh-prepare-save-mail-hook nil
  50   "Hook run narrowed to an article before saving.")
  51
  52 (defvoo nnmh-be-safe nil
  53   "If non-nil, nnmh will check all articles to make sure whether they are new or not.
  54 Go through the .nnmh-articles file and compare with the actual
  55 articles in this folder.  The articles that are \"new\" will be marked
  56 as unread by Gnus.")
  57
  58 \f
  59
  60 (defconst nnmh-version "nnmh 1.0"
  61   "nnmh version.")
  62
  63 (defvoo nnmh-current-directory nil
  64   "Current news group directory.")
  65
  66 (defvoo nnmh-status-string "")
  67 (defvoo nnmh-group-alist nil)
  68 ;; Don't even think about setting this variable.  It does not exist.
  69 ;; Forget about it.  Uh-huh.  Nope.  Nobody here.  It's only bound
  70 ;; dynamically by certain functions in nndraft.
  71 (defvar nnmh-allow-delete-final nil)
  72
  73 \f
  74
  75 ;;; Interface functions.
  76
  77 (nnoo-define-basics nnmh)
  78
  79 (deffoo nnmh-retrieve-headers (articles &optional newsgroup server fetch-old)
  80   (save-excursion
  81     (set-buffer nntp-server-buffer)
  82     (erase-buffer)
  83     (let* ((file nil)
  84            (number (length articles))
  85            (large (and (numberp nnmail-large-newsgroup)
  86                        (> number nnmail-large-newsgroup)))
  87            (count 0)
  88            (file-name-coding-system nnmail-pathname-coding-system)
  89            beg article)
  90       (nnmh-possibly-change-directory newsgroup server)
  91       ;; We don't support fetching by Message-ID.
  92       (if (stringp (car articles))
  93           'headers
  94         (while articles
  95           (when (and (file-exists-p
  96                       (setq file (concat (file-name-as-directory
  97                                           nnmh-current-directory)
  98                                          (int-to-string
  99                                           (setq article (pop articles))))))
 100                      (not (file-directory-p file)))
 101             (insert (format "221 %d Article retrieved.\n" article))
 102             (setq beg (point))
 103             (nnheader-insert-head file)
 104             (goto-char beg)
 105             (if (search-forward "\n\n" nil t)
 106                 (forward-char -1)
 107               (goto-char (point-max))
 108               (insert "\n\n"))
 109             (insert ".\n")
 110             (delete-region (point) (point-max)))
 111           (setq count (1+ count))
 112
 113           (and large
 114                (zerop (% count 20))
 115                (nnheader-message 5 "nnmh: Receiving headers... %d%%"
 116                                  (/ (* count 100) number))))
 117
 118         (when large
 119           (nnheader-message 5 "nnmh: Receiving headers...done"))
 120
 121         (nnheader-fold-continuation-lines)
 122         'headers))))
 123
 124 (deffoo nnmh-open-server (server &optional defs)
 125   (nnoo-change-server 'nnmh server defs)
 126   (when (not (file-exists-p nnmh-directory))
 127     (condition-case ()
 128         (make-directory nnmh-directory t)
 129       (error t)))
 130   (cond
 131    ((not (file-exists-p nnmh-directory))
 132     (nnmh-close-server)
 133     (nnheader-report 'nnmh "Couldn't create directory: %s" nnmh-directory))
 134    ((not (file-directory-p (file-truename nnmh-directory)))
 135     (nnmh-close-server)
 136     (nnheader-report 'nnmh "Not a directory: %s" nnmh-directory))
 137    (t
 138     (nnheader-report 'nnmh "Opened server %s using directory %s"
 139                      server nnmh-directory)
 140     t)))
 141
 142 (deffoo nnmh-request-article (id &optional newsgroup server buffer)
 143   (nnmh-possibly-change-directory newsgroup server)
 144   (let ((file (if (stringp id)
 145                   nil
 146                 (concat nnmh-current-directory (int-to-string id))))
 147         (file-name-coding-system nnmail-pathname-coding-system)
 148         (nntp-server-buffer (or buffer nntp-server-buffer)))
 149     (and (stringp file)
 150          (file-exists-p file)
 151          (not (file-directory-p file))
 152          (save-excursion (nnmail-find-file file))
 153          (string-to-int (file-name-nondirectory file)))))
 154
 155 (deffoo nnmh-request-group (group &optional server dont-check)
 156   (nnheader-init-server-buffer)
 157   (nnmh-possibly-change-directory group server)
 158   (let ((pathname (nnmail-group-pathname group nnmh-directory))
 159         (file-name-coding-system nnmail-pathname-coding-system)
 160         dir)
 161     (cond
 162      ((not (file-directory-p pathname))
 163       (nnheader-report
 164        'nnmh "Can't select group (no such directory): %s" group))
 165      (t
 166       (setq nnmh-current-directory pathname)
 167       (and nnmh-get-new-mail
 168            nnmh-be-safe
 169            (nnmh-update-gnus-unreads group))
 170       (cond
 171        (dont-check
 172         (nnheader-report 'nnmh "Selected group %s" group)
 173         t)
 174        (t
 175         ;; Re-scan the directory if it's on a foreign system.
 176         (nnheader-re-read-dir pathname)
 177         (setq dir
 178               (sort
 179                (mapcar (lambda (name) (string-to-int name))
 180                        (directory-files pathname nil &