lisp/mhspool.el

   1 ;;; mhspool.el --- MH folder access using NNTP for GNU Emacs
   2
   3 ;; Copyright (C) 1988, 1989, 1990 Free Software Foundation, Inc.
   4
   5 ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
   6 ;; Maintainer: FSF
   7 ;; Keywords: mail, news
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  23 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This package enables you to read mail or articles in MH folders, or
  28 ;; articles saved by GNUS. In any case, the file names of mail or
  29 ;; articles must consist of only numeric letters.
  30
  31 ;; Before using this package, you have to create a server specific
  32 ;; startup file according to the directory which you want to read. For
  33 ;; example, if you want to read mail under the directory named
  34 ;; `~/Mail', the file must be a file named `.newsrc-:Mail'. (There is
  35 ;; no way to specify hierarchical directory now.) In this case, the
  36 ;; name of the NNTP server passed to GNUS must be `:Mail'.
  37
  38 ;;; Code:
  39
  40 (require 'nntp)
  41
  42 (defvar mhspool-list-directory-switches '("-R")
  43   "*Switches for `nntp-request-list' to pass to `ls' for gettting file lists.
  44 One entry should appear on one line. You may need to add `-1' option.")
  45
  46 \f
  47
  48 (defconst mhspool-version "MHSPOOL 1.5"
  49   "Version numbers of this version of MHSPOOL.")
  50
  51 (defvar mhspool-spool-directory "~/Mail"
  52   "Private mail directory.")
  53
  54 (defvar mhspool-current-directory nil
  55   "Current news group directory.")
  56
  57 ;;;
  58 ;;; Replacement of Extended Command for retrieving many headers.
  59 ;;;
  60
  61 (defun mhspool-retrieve-headers (sequence)
  62   "Return list of article headers specified by SEQUENCE of article id.
  63 The format of list is
  64  `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'.
  65 Reader macros for the vector are defined as `nntp-header-FIELD'.
  66 Writer macros for the vector are defined as `nntp-set-header-FIELD'.
  67 News group must be selected before calling me."
  68   (save-excursion
  69     (set-buffer nntp-server-buffer)
  70     ;;(erase-buffer)
  71     (let ((file nil)
  72           (number (length sequence))
  73           (count 0)
  74           (headers nil)                 ;Result list.
  75           (article 0)
  76           (subject nil)
  77           (message-id nil)
  78           (from nil)
  79           (xref nil)
  80           (lines 0)
  81           (date nil)
  82           (references nil))
  83       (while sequence
  84         ;;(nntp-send-strings-to-server "HEAD" (car sequence))
  85         (setq article (car sequence))
  86         (setq file
  87               (concat mhspool-current-directory (prin1-to-string article)))
  88         (if (and (file-exists-p file)
  89                  (not (file-directory-p file)))
  90             (progn
  91               (erase-buffer)
  92               (insert-file-contents file)
  93               ;; Make message body invisible.
  94               (goto-char (point-min))
  95               (search-forward "\n\n" nil 'move)
  96               (narrow-to-region (point-min) (point))
  97               ;; Fold continuation lines.
  98               (goto-char (point-min))
  99               (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
 100                 (replace-match " " t t))
 101               ;; Make it possible to search for `\nFIELD'.
 102               (goto-char (point-min))
 103               (insert "\n")
 104               ;; Extract From:
 105               (goto-char (point-min))
 106               (if (search-forward "\nFrom: " nil t)
 107                   (setq from (buffer-substring
 108                               (point)
 109                               (save-excursion (end-of-line) (point))))
 110                 (setq from "(Unknown User)"))
 111               ;; Extract Subject:
 112               (goto-char (point-min))
 113               (if (search-forward "\nSubject: " nil t)
 114                   (setq subject (buffer-substring
 115                                  (point)
 116                                  (save-excursion (end-of-line) (point))))
 117                 (setq subject "(None)"))
 118               ;; Extract Message-ID:
 119               (goto-char (point-min))
 120               (if (search-forward "\nMessage-ID: " nil t)
 121                   (setq message-id (buffer-substring
 122                                     (point)
 123                                     (save-excursion (end-of-line) (point))))
 124                 (setq message-id nil))
 125               ;; Extract Date:
 126               (goto-char (point-min))
 127               (if (search-forward "\nDate: " nil t)
 128                   (setq date (buffer-substring
 129                               (point)
 130                               (save-excursion (end-of-line) (point))))
 131                 (setq date nil))
 132               ;; Extract Lines:
 133               (goto-char (point-min))
 134               (if (search-forward "\nLines: " nil t)
 135                   (setq lines (string-to-int
 136                                (buffer-substring
 137                                 (point)
 138                                 (save-excursion (end-of-line) (point)))))
 139                 (setq lines 0))
 140               ;; Extract Xref:
 141               (goto-char (point-min))
 142               (if (search-forward "\nXref: " nil t)
 143                   (setq xref (buffer-substring
 144                               (point)
 145                               (save-excursion (end-of-line) (point))))
 146                 (setq xref nil))
 147               ;; Extract References:
 148               ;; If no References: field, use In-Reply-To: field instead.
 149               ;; Suggested by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA).
 150               (goto-char (point-min))
 151               (if (or (search-forward "\nReferences: " nil t)
 152                       (search-forward "\nIn-Reply-To: " nil t))
 153                   (setq references (buffer-substring
 154                                     (point)
 155                                     (save-excursion (end-of-line) (point))))
 156                 (setq references nil))
 157               (setq headers
 158                     (cons (vector article subject from
 159                                   xref lines date
 160                                   message-id references) headers))
 161               ))
 162         (setq sequence (cdr sequence))
 163         (setq count (1+ count))
 164         (and (numberp nntp-large-newsgroup)
 165              (> number nntp-large-newsgroup)
 166              (zerop (% count 20))
 167              (message "MHSPOOL: %d%% of headers received."
 168                       (/ (* count 100) number)))
 169         )
 170       (and (numberp nntp-large-newsgroup)
 171            (> number nntp-large-newsgroup)
 172            (message "MHSPOOL: 100%% of headers received."))
 173       (nreverse headers)
 174       )))
 175
 176 \f
 177 ;;;
 178 ;;; Replacement of NNTP Raw Interface.
 179 ;;;
 180
 181 (defun mhspool-open-server (host &optional service)
 182   "Open news server on HOST.
 183 If HOST is nil, use value of environment variable `NNTPSERVER'.
 184 If optional argument SERVICE is non-nil, open by the service name."
 185   (let ((host (or host (getenv "NNTPSERVER")))
 186         (status nil))
 187     ;; Get directory name from HOST name.
 188     (if (string-match ":\\(.+\\)$" host)
 189         (progn
 190           (setq mhspool-spool-directory
 191                 (file-name-as-directory
 192                  (expand-file-name
 193                   (substring host (match-beginning 1) (match-end 1))
 194                   (expand-file-name "~/" nil))))
 195           (setq host (system-name)))
 196       (setq mhspool-spool-directory nil))
 197     (setq nntp-status-message-string "")
 198     (cond ((and (stringp host)
 199                 (stringp mhspool-spool-directory)
 200                 (file-directory-p mhspool-spool-directory)
 201                 (string-equal host (system-name)))
 202            (setq status (mhspool-open-server-internal host service)))
 203           ((string-equal host (system-name))
 204            (setq nntp-status-message-string
 205                  (format "No such directory: %s.  Goodbye."
 206                          mhspool-spool-directory)))
 207           ((null host)
 208            (setq nntp-status-message-string "NNTP server is not specified."))
 209           (t
 210            (setq nntp-status-message-string
 211                  (format "MHSPOOL: cannot talk to %s." host)))
 212           )
 213     status
 214     ))
 215
 216 (defun mhspool-close-server ()
 217   "Close news server."
 218   (mhspool-close-server-internal))
 219
 220 (fset 'mhspool-request-quit (symbol-function 'mhspool-close-server))
 221
 222 (defun mhspool-server-opened ()
 223   "Return server process status, T or NIL.
 224 If the stream is opened, return T, otherwise return NIL."
 225   (and nntp-server-buffer
 226        (get-buffer nntp-server-buffer)))
 227
 228 (defun mhspool-status-message ()
 229   "Return server status response as string."
 230   nntp-status-message-string
 231   )
 232
 233 (defun mhspool-request-article (id)
 234   "Select article by message ID (or number)."
 235   (let ((file (concat mhspool-current-directory (prin1-to-string id))))
 236     (if (and (stringp file)
 237              (file-exists-p file)
 238              (not (file-directory-p file)))
 239         (save-excursion
 240           (mhspool-find-file file)))
 241     ))
 242
 243 (defun mhspool-request-body (id)
 244   "Select article body by message ID (or number)."
 245   (if (mhspool-request-article id)
 246       (save-excursion
 247         (set-buffer nntp-server-buffer)
 248         (goto-char (point-min))
 249         (if (search-forward "\n\n" nil t)
 250             (delete-region (point-min) (point)))
 251         t
 252         )
 253     ))
 254
 255 (defun mhspool-request-head (id)
 256   "Select article head by message ID (or number)."
 257   (if (mhspool-request-article id)
 258       (save-excursion
 259         (set-buffer nntp-server-buffer)
 260         (goto-char (point-min))
 261         (if (search-forward "\n\n" nil t)
 262             (delete-region (1- (point)) (point-max)))
 263         t
 264         )
 265     ))
 266
 267 (defun mhspool-request-stat (id)
 268   "Select article by message ID (or number)."
 269   (error "MHSPOOL: STAT is not implemented."))
 270
 271 (defun mhspool-request-group (group)
 272   "Select news GROUP."
 273   (cond ((file-directory-p
 274           (mhspool-article-pathname group))
 275          ;; Mail/NEWS.GROUP/N
 276          (setq mhspool-current-directory
 277                (mhspool-article-pathname group)))
 278         ((file-directory-p
 279           (mhspool-article-pathname
 280            (mhspool-replace-chars-in-string group ?. ?/)))
 281          ;; Mail/NEWS/GROUP/N
 282          (setq mhspool-current-directory
 283                (mhspool-article-pathname
 284                 (mhspool-replace-chars-in-string group ?. ?/))))
 285         ))
 286
 287 (defun mhspool-request-list ()
 288   "List valid newsgoups."
 289   (save-excursion
 290     (let* ((newsgroup nil)
 291            (articles nil)
 292            (directory (file-name-as-directory
 293                        (expand-file-name mhspool-spool-directory nil)))
 294            (folder-regexp (concat "^" (regexp-quote directory) "\\(.+\\):$"))
 295            (buffer (get-buffer-create " *GNUS file listing*")))
 296       (set-buffer nntp-server-buffer)
 297       (erase-buffer)
 298       (set-buffer buffer)
 299       (erase-buffer)
 300       (apply 'call-process
 301              "ls" nil t nil
 302              (append mhspool-list-directory-switches (list directory)))
 303       (goto-char (point-min))
 304       (while (re-search-forward folder-regexp nil t)
 305         (setq newsgroup
 306               (mhspool-replace-chars-in-string
 307                (buffer-substring (match-beginning 1) (match-end 1)) ?/ ?.))
 308         (setq articles nil)
 309         (forward-line 1)                ;(beginning-of-line)
 310         ;; Thank nobu@flab.fujitsu.junet for his bug fixes.
 311         (while (and (not (eobp))
 312                     (not (looking-at "^$")))
 313           (if (looking-at "^[0-9]+$")
 314               (setq articles
 315                     (cons (string-to-int
 316                            (buffer-substring
 317                             (match-beginning 0) (match-end 0)))
 318                           articles)))
 319           (forward-line 1))
 320         (if articles
 321             (princ (format "%s %d %d n\n" newsgroup
 322                            (apply (function max) articles)
 323                            (apply (function min) articles))
 324                    nntp-server-buffer))
 325         )
 326       (kill-buffer buffer)
 327       (set-buffer nntp-server-buffer)
 328       (buffer-size)
 329       )))
 330
 331 (defun mhspool-request-last ()
 332   "Set current article pointer to the previous article in the current newsgroup."
 333   (error "MHSPOOL: LAST is not implemented."))
 334
 335 (defun mhspool-request-next ()
 336   "Advance current article pointer."
 337   (error "MHSPOOL: NEXT is not implemented."))
 338
 339 (defun mhspool-request-post ()
 340   "Post a new news in current buffer."
 341   (setq nntp-status-message-string "MHSPOOL: what do you mean post?")
 342   nil
 343   )
 344
 345 \f
 346 ;;;
 347 ;;; Replacement of Low-Level Interface to NNTP Server.
 348 ;;;
 349
 350 (defun mhspool-open-server-internal (host &optional service)
 351   "Open connection to news server on HOST by SERVICE (default is nntp)."
 352   (save-excursion
 353     (if (not (string-equal host (system-name)))
 354         (error "MHSPOOL: cannot talk to %s." host))
 355     ;; Initialize communication buffer.
 356     (setq nntp-server-buffer (get-buffer-create " *nntpd*"))
 357     (set-buffer nntp-server-buffer)
 358     (buffer-flush-undo (current-buffer))
 359     (erase-buffer)
 360     (kill-all-local-variables)
 361     (setq case-fold-search t)           ;Should ignore case.
 362     (setq nntp-server-process nil)
 363     (setq nntp-server-name host)
 364     ;; It is possible to change kanji-fileio-code in this hook.
 365     (run-hooks 'nntp-server-hook)
 366     t
 367     ))
 368
 369 (defun mhspool-close-server-internal ()
 370   "Close connection to news server."
 371   (if nntp-server-buffer
 372       (kill-buffer nntp-server-buffer))
 373   (setq nntp-server-buffer nil)
 374   (setq nntp-server-process nil))
 375
 376 (defun mhspool-find-file (file)
 377   "Insert FILE in server buffer safely."
 378   (set-buffer nntp-server-buffer)
 379   (erase-buffer)
 380   (condition-case ()
 381       (progn
 382         (insert-file-contents file)
 383         (goto-char (point-min))
 384         ;; If there is no body, `^L' appears at end of file. Special
 385         ;; hack for MH folder.
 386         (and (search-forward "\n\n" nil t)
 387              (string-equal (buffer-substring (point) (point-max)) "\^L")
 388              (delete-char 1))
 389         t
 390         )
 391     (file-error nil)
 392     ))
 393
 394 (defun mhspool-article-pathname (group)
 395   "Make pathname for GROUP."
 396   (concat (file-name-as-directory mhspool-spool-directory) group "/"))
 397
 398 (defun mhspool-replace-chars-in-string (string from to)
 399   "Replace characters in STRING from FROM to TO."
 400   (let ((string (substring string 0))   ;Copy string.
 401         (len (length string))
 402         (idx 0))
 403     ;; Replace all occurence of FROM with TO.
 404     (while (< idx len)
 405       (if (= (aref string idx) from)
 406           (aset string idx to))
 407       (setq idx (1+ idx)))
 408     string
 409     ))
 410
 411 (provide 'mhspool)
 412
 413 ;;; mhspool.el ends here