lisp/mhspool.el

   1 ;;; mhspool.el --- MH folder access using NNTP for GNU Emacs
   2
   3 ;; Copyright (C) 1988, 1989, 1990, 1993 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-folders-method
  43   (function mhspool-list-folders-using-sh)
  44   "*Function to list files in folders.
  45 The function should accept a directory as its argument, and fill the
  46 current buffer with file and directory names.  The output format must
  47 be the same as that of 'ls -R1'.  Two functions
  48 mhspool-list-folders-using-ls and mhspool-list-folders-using-sh are
  49 provided now.  I suppose the later is faster.")
  50
  51 (defvar mhspool-list-directory-switches '("-R")
  52   "*Switches for mhspool-list-folders-using-ls to pass to `ls' for getting file lists.
  53 One entry should appear on one line. You may need to add `-1' option.")
  54
  55 \f
  56
  57 (defconst mhspool-version "MHSPOOL 1.8"
  58   "Version numbers of this version of MHSPOOL.")
  59
  60 (defvar mhspool-spool-directory "~/Mail"
  61   "Private mail directory.")
  62
  63 (defvar mhspool-current-directory nil
  64   "Current news group directory.")
  65
  66 ;;;
  67 ;;; Replacement of Extended Command for retrieving many headers.
  68 ;;;
  69
  70 (defun mhspool-retrieve-headers (sequence)
  71   "Return list of article headers specified by SEQUENCE of article id.
  72 The format of list is
  73  `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'.
  74 If there is no References: field, In-Reply-To: field is used instead.
  75 Reader macros for the vector are defined as `nntp-header-FIELD'.
  76 Writer macros for the vector are defined as `nntp-set-header-FIELD'.
  77 Newsgroup must be selected before calling this."
  78   (save-excursion
  79     (set-buffer nntp-server-buffer)
  80     ;;(erase-buffer)
  81     (let ((file nil)
  82           (number (length sequence))
  83           (count 0)
  84           (headers nil)                 ;Result list.
  85           (article 0)
  86           (subject nil)
  87           (message-id nil)
  88           (from nil)
  89           (xref nil)
  90           (lines 0)
  91           (date nil)
  92           (references nil))
  93       (while sequence
  94         ;;(nntp-send-strings-to-server "HEAD" (car sequence))
  95         (setq article (car sequence))
  96         (setq file
  97               (concat mhspool-current-directory (prin1-to-string article)))
  98         (if (and (file-exists-p file)
  99                  (not (file-directory-p file)))
 100             (progn
 101               (erase-buffer)
 102               (insert-file-contents file)
 103               ;; Make message body invisible.
 104               (goto-char (point-min))
 105               (search-forward "\n\n" nil 'move)
 106               (narrow-to-region (point-min) (point))
 107               ;; Fold continuation lines.
 108               (goto-char (point-min))
 109               (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
 110                 (replace-match " " t t))
 111               ;; Make it possible to search for `\nFIELD'.
 112               (goto-char (point-min))
 113               (insert "\n")
 114               ;; Extract From:
 115               (goto-char (point-min))
 116               (if (search-forward "\nFrom: " nil t)
 117                   (setq from (buffer-substring
 118                               (point)
 119                               (save-excursion (end-of-line) (point))))
 120                 (setq from "(Unknown User)"))
 121               ;; Extract Subject:
 122               (goto-char (point-min))
 123               (if (search-forward "\nSubject: " nil t)
 124                   (setq subject (buffer-substring
 125                                  (point)
 126                                  (save-excursion (end-of-line) (point))))
 127                 (setq subject "(None)"))
 128               ;; Extract Message-ID:
 129               (goto-char (point-min))
 130               (if (search-forward "\nMessage-ID: " nil t)
 131                   (setq message-id (buffer-substring
 132                                     (point)
 133                                     (save-excursion (end-of-line) (point))))
 134                 (setq message-id nil))
 135               ;; Extract Date:
 136               (goto-char (point-min))
 137               (if (search-forward "\nDate: " nil t)
 138                   (setq date (buffer-substring
 139                               (point)
 140                               (save-excursion (end-of-line) (point))))
 141                 (setq date nil))
 142               ;; Extract Lines:
 143               (goto-char (point-min))
 144               (if (search-forward "\nLines: " nil t)
 145                   (setq lines (string-to-int
 146                                (buffer-substring
 147                                 (point)
 148                                 (save-excursion (end-of-line) (point)))))
 149                 ;; Count lines since there is no lines field in most cases.
 150                 (setq lines
 151                       (save-restriction
 152                         (goto-char (point-max))
 153                         (widen)
 154                         (count-lines (point) (point-max)))))
 155               ;; Extract Xref:
 156               (goto-char (point-min))
 157               (if (search-forward "\nXref: " nil t)
 158                   (setq xref (buffer-substring
 159                               (point)
 160                               (save-excursion (end-of-line) (point))))
 161                 (setq xref nil))
 162               ;; Extract References:
 163               ;; If no References: field, use In-Reply-To: field instead.
 164               ;; Suggested by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA).
 165               (goto-char (point-min))
 166               (if (or (search-forward "\nReferences: " nil t)
 167                       (search-forward "\nIn-Reply-To: " nil t))
 168                   (setq references (buffer-substring
 169                                     (point)
 170                                     (save-excursion (end-of-line) (point))))
 171                 (setq references nil))
 172               ;; Collect valid article only.
 173               (and article
 174                    message-id
 175                    (setq headers
 176                          (cons (vector article subject from
 177                                        xref lines date
 178                                        message-id references) headers)))
 179               ))
 180         (setq sequence (cdr sequence))
 181         (setq count (1+ count))
 182         (and (numberp nntp-large-newsgroup)
 183              (> number nntp-large-newsgroup)
 184              (zerop (% count 20))
 185              (message "MHSPOOL: Receiving headers... %d%%"
 186                       (/ (* count 100) number)))
 187         )
 188       (and (numberp nntp-large-newsgroup)
 189            (> number nntp-large-newsgroup)
 190            (message "MHSPOOL: Receiving headers... done"))
 191       (nreverse headers)
 192       )))
 193
 194 \f
 195 ;;;
 196 ;;; Replacement of NNTP Raw Interface.
 197 ;;;
 198
 199 (defun mhspool-open-server (host &optional service)
 200   "Open news server on HOST.
 201 If HOST is nil, use value of environment variable `NNTPSERVER'.
 202 If optional argument SERVICE is non-nil, open by the service name."
 203   (let ((host (or host (getenv "NNTPSERVER")))
 204         (status nil))
 205     ;; Get directory name from HOST name.
 206     (if (string-match ":\\(.+\\)$" host)
 207         (progn
 208           (setq mhspool-spool-directory
 209                 (file-name-as-directory
 210                  (expand-file-name
 211                   (substring host (match-beginning 1) (match-end 1))
 212                   (expand-file-name "~/" nil))))
 213           (setq host (system-name)))
 214       (setq mhspool-spool-directory nil))
 215     (setq nntp-status-string "")
 216     (cond ((and (stringp host)
 217                 (stringp mhspool-spool-directory)
 218                 (file-directory-p mhspool-spool-directory)
 219                 (string-equal host (system-name)))
 220            (setq status (mhspool-open-server-internal host service)))
 221           ((string-equal host (system-name))
 222            (setq nntp-status-string
 223                  (format "No such directory: %s.  Goodbye."
 224                          mhspool-spool-directory)))
 225           ((null host)
 226            (setq nntp-status-string "NNTP server is not specified."))
 227           (t
 228            (setq nntp-status-string
 229                  (format "MHSPOOL: cannot talk to %s." host)))
 230           )
 231     status
 232     ))
 233
 234 (defun mhspool-close-server ()
 235   "Close news server."
 236   (mhspool-close-server-internal))
 237
 238 (fset 'mhspool-request-quit (symbol-function 'mhspool-close-server))
 239
 240 (defun mhspool-server-opened ()
 241   "Return server process status, T or NIL.
 242 If the stream is opened, return T, otherwise return NIL."
 243   (and nntp-server-buffer
 244        (get-buffer nntp-server-buffer)))
 245
 246 (defun mhspool-status-message ()
 247   "Return server status response as string."
 248   nntp-status-string
 249   )
 250
 251 (defun mhspool-request-article (id)
 252   "Select article by message ID (or number)."
 253   (let ((file (concat mhspool-current-directory (prin1-to-string id))))
 254     (if (and (stringp file)
 255              (file-exists-p file)
 256              (not (file-directory-p file)))
 257         (save-excursion
 258           (mhspool-find-file file)))
 259     ))
 260
 261 (defun mhspool-request-body (id)
 262   "Select article body by message ID (or number)."
 263   (if (mhspool-request-article id)
 264       (save-excursion
 265         (set-buffer nntp-server-buffer)
 266         (goto-char (point-min))
 267         (if (search-forward "\n\n" nil t)
 268             (delete-region (point-min) (point)))
 269         t
 270         )
 271     ))
 272
 273 (defun mhspool-request-head (id)
 274   "Select article head by message ID (or number)."
 275   (if (mhspool-request-article id)
 276       (save-excursion
 277         (set-buffer nntp-server-buffer)
 278         (goto-char (point-min))
 279         (if (search-forward "\n\n" nil t)
 280             (delete-region (1- (point)) (point-max)))
 281         t
 282         )
 283     ))
 284
 285 (defun mhspool-request-stat (id)
 286   "Select article by message ID (or number)."
 287   (setq nntp-status-string "MHSPOOL: STAT is not implemented.")
 288   nil
 289   )
 290
 291 (defun mhspool-request-group (group)
 292   "Select news GROUP."
 293   (cond ((file-directory-p
 294           (mhspool-article-pathname group))
 295          ;; Mail/NEWS.GROUP/N
 296          (setq mhspool-current-directory
 297                (mhspool-article-pathname group)))
 298         ((file-directory-p
 299           (mhspool-article-pathname
 300            (mhspool-replace-chars-in-string group ?. ?/)))
 301          ;; Mail/NEWS/GROUP/N
 302          (setq mhspool-current-directory
 303                (mhspool-article-pathname
 304                 (mhspool-replace-chars-in-string group ?. ?/))))
 305         ))
 306
 307 (defun mhspool-request-list ()
 308   "List active newsgoups."
 309   (save-excursion
 310     (let* ((newsgroup nil)
 311            (articles nil)
 312            (directory (file-name-as-directory
 313                        (expand-file-name mhspool-spool-directory nil)))
 314            (folder-regexp (concat "^" (regexp-quote directory) "\\(.+\\):$"))
 315            (buffer (get-buffer-create " *MHSPOOL File List*")))
 316       (set-buffer nntp-server-buffer)
 317       (erase-buffer)
 318       (set-buffer buffer)
 319       (erase-buffer)
 320 ;;      (apply 'call-process
 321 ;;           "ls" nil t nil
 322 ;;           (append mhspool-list-directory-switches (list directory)))
 323       (funcall mhspool-list-folders-method directory)
 324       (goto-char (point-min))
 325       (while (re-search-forward folder-regexp nil t)
 326         (setq newsgroup
 327               (mhspool-replace-chars-in-string
 328                (buffer-substring (match-beginning 1) (match-end 1)) ?/ ?.))
 329         (setq articles nil)
 330         (forward-line 1)                ;(beginning-of-line)
 331         ;; Thank nobu@flab.fujitsu.junet for his bug fixes.
 332         (while (and (not (eobp))
 333                     (not (looking-at "^$")))
 334           (if (looking-at "^[0-9]+$")
 335               (setq articles
 336                     (cons (string-to-int
 337                            (buffer-substring
 338                             (match-beginning 0) (match-end 0)))
 339                           articles)))
 340           (forward-line 1))
 341         (if articles
 342             (princ (format "%s %d %d n\n" newsgroup
 343                            (apply (function max) articles)
 344                            (apply (function min) articles))
 345                    nntp-server-buffer))
 346         )
 347       (kill-buffer buffer)
 348       (set-buffer nntp-server-buffer)
 349       (buffer-size)
 350       )))
 351
 352 (defun mhspool-request-list-newsgroups ()
 353   "List newsgoups (defined in NNTP2)."
 354   (setq nntp-status-string "MHSPOOL: LIST NEWSGROUPS is not implemented.")
 355   nil
 356   )
 357
 358 (defun mhspool-request-list-distributions ()
 359   "List distributions (defined in NNTP2)."
 360   (setq nntp-status-string "MHSPOOL: LIST DISTRIBUTIONS is not implemented.")
 361   nil
 362   )
 363
 364 (defun mhspool-request-last ()
 365   "Set current article pointer to the previous article
 366 in the current news group."
 367   (setq nntp-status-string "MHSPOOL: LAST is not implemented.")
 368   nil
 369   )
 370
 371 (defun mhspool-request-next ()
 372   "Advance current article pointer."
 373   (setq nntp-status-string "MHSPOOL: NEXT is not implemented.")
 374   nil
 375   )
 376
 377 (defun mhspool-request-post ()
 378   "Post a new news in current buffer."
 379   (setq nntp-status-string "MHSPOOL: POST: what do you mean?")
 380   nil
 381   )
 382
 383 \f
 384 ;;;
 385 ;;; Replacement of Low-Level Interface to NNTP Server.
 386 ;;;
 387
 388 (defun mhspool-open-server-internal (host &optional service)
 389   "Open connection to news server on HOST by SERVICE (default is nntp)."
 390   (save-excursion
 391     (if (not (string-equal host (system-name)))
 392         (error "MHSPOOL: cannot talk to %s." host))
 393     ;; Initialize communication buffer.
 394     (setq nntp-server-buffer (get-buffer-create " *nntpd*"))
 395     (set-buffer nntp-server-buffer)
 396     (buffer-flush-undo (current-buffer))
 397     (erase-buffer)
 398     (kill-all-local-variables)
 399     (setq case-fold-search t)           ;Should ignore case.
 400     (setq nntp-server-process nil)
 401     (setq nntp-server-name host)
 402     ;; It is possible to change kanji-fileio-code in this hook.
 403     (run-hooks 'nntp-server-hook)
 404     t
 405     ))
 406
 407 (defun mhspool-close-server-internal ()
 408   "Close connection to news server."
 409   (if nntp-server-buffer
 410       (kill-buffer nntp-server-buffer))
 411   (setq nntp-server-buffer nil)
 412   (setq nntp-server-process nil))
 413
 414 (defun mhspool-find-file (file)
 415   "Insert FILE in server buffer safely."
 416   (set-buffer nntp-server-buffer)
 417   (erase-buffer)
 418   (condition-case ()
 419       (progn
 420         (insert-file-contents file)
 421         (goto-char (point-min))
 422         ;; If there is no body, `^L' appears at end of file. Special
 423         ;; hack for MH folder.
 424         (and (search-forward "\n\n" nil t)
 425              (string-equal (buffer-substring (point) (point-max)) "\^L")
 426              (delete-char 1))
 427         t
 428         )
 429     (file-error nil)
 430     ))
 431
 432 (defun mhspool-article-pathname (group)
 433   "Make pathname for GROUP."
 434   (concat (file-name-as-directory mhspool-spool-directory) group "/"))
 435
 436 (defun mhspool-replace-chars-in-string (string from to)
 437   "Replace characters in STRING from FROM to TO."
 438   (let ((string (substring string 0))   ;Copy string.
 439         (len (length string))
 440         (idx 0))
 441     ;; Replace all occurrences of FROM with TO.
 442     (while (< idx len)
 443       (if (= (aref string idx) from)
 444           (aset string idx to))
 445       (setq idx (1+ idx)))
 446     string
 447     ))
 448
 449 \f
 450 ;; Methods for listing files in folders.
 451
 452 (defun mhspool-list-folders-using-ls (directory)
 453   "List files in folders under DIRECTORY using 'ls'."
 454   (apply 'call-process
 455          "ls" nil t nil
 456          (append mhspool-list-directory-switches (list directory))))
 457
 458 ;; Basic ideas by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA)
 459
 460 (defun mhspool-list-folders-using-sh (directory)
 461   "List files in folders under DIRECTORY using '/bin/sh'."
 462   (let ((buffer (current-buffer))
 463         (script (get-buffer-create " *MHSPOOL Shell Script Buffer*")))
 464     (save-excursion
 465       (save-restriction
 466         (set-buffer script)
 467         (erase-buffer)
 468         ;; /bin/sh script which does 'ls -R'.
 469         (insert
 470          "PS2=
 471           ffind() {
 472                 cd $1; echo $1:
 473                 ls -1
 474                 echo
 475                 for j in `echo *[a-zA-Z]*`
 476                 do
 477                   if [ -d $1/$j ]; then
 478                         ffind $1/$j
 479                   fi
 480                 done
 481           }
 482           cd " directory "; ffind `pwd`; exit 0\n")
 483         (call-process-region (point-min) (point-max) "sh" nil buffer nil)
 484         ))
 485     (kill-buffer script)
 486     ))
 487
 488 (provide 'mhspool)
 489
 490 ;;; mhspool.el ends here