lisp/mhspool.el

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