lisp/nnspool.el

   1 ;;; nnspool.el --- spool 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 ;; Keywords: news
   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 ;;; Code:
  25
  26 (require 'nntp)
  27
  28 (defvar nnspool-inews-program news-inews-program
  29   "*Program to post news.")
  30
  31 (defvar nnspool-inews-switches '("-h")
  32   "*Switches for nnspool-request-post to pass to `inews' for posting news.")
  33
  34 (defvar nnspool-spool-directory news-path
  35   "*Local news spool directory.")
  36
  37 (defvar nnspool-active-file "/usr/lib/news/active"
  38   "*Local news active file.")
  39
  40 (defvar nnspool-newsgroups-file "/usr/lib/news/newsgroups"
  41   "*Local news newsgroups file.")
  42
  43 (defvar nnspool-distributions-file "/usr/lib/news/distributions"
  44   "*Local news distributions file.")
  45
  46 (defvar nnspool-history-file "/usr/lib/news/history"
  47   "*Local news history file.")
  48
  49 \f
  50
  51 (defconst nnspool-version "NNSPOOL 1.12"
  52   "Version numbers of this version of NNSPOOL.")
  53
  54 (defvar nnspool-current-directory nil
  55   "Current news group directory.")
  56
  57 ;;;
  58 ;;; Replacement of Extended Command for retrieving many headers.
  59 ;;;
  60
  61 (defun nnspool-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 If there is no References: field, In-Reply-To: field is used instead.
  66 Reader macros for the vector are defined as `nntp-header-FIELD'.
  67 Writer macros for the vector are defined as `nntp-set-header-FIELD'.
  68 Newsgroup must be selected before calling this."
  69   (save-excursion
  70     (set-buffer nntp-server-buffer)
  71     ;;(erase-buffer)
  72     (let ((file nil)
  73           (number (length sequence))
  74           (count 0)
  75           (headers nil)                 ;Result list.
  76           (article 0)
  77           (subject nil)
  78           (message-id nil)
  79           (from nil)
  80           (xref nil)
  81           (lines 0)
  82           (date nil)
  83           (references nil))
  84       (while sequence
  85         ;;(nntp-send-strings-to-server "HEAD" (car sequence))
  86         (setq article (car sequence))
  87         (setq file
  88               (concat nnspool-current-directory (prin1-to-string article)))
  89         (if (and (file-exists-p file)
  90                  (not (file-directory-p file)))
  91             (progn
  92               (erase-buffer)
  93               (insert-file-contents file)
  94               ;; Make message body invisible.
  95               (goto-char (point-min))
  96               (search-forward "\n\n" nil 'move)
  97               (narrow-to-region (point-min) (point))
  98               ;; Fold continuation lines.
  99               (goto-char (point-min))
 100               (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
 101                 (replace-match " " t t))
 102               ;; Make it possible to search for `\nFIELD'.
 103               (goto-char (point-min))
 104               (insert "\n")
 105               ;; Extract From:
 106               (goto-char (point-min))
 107               (if (search-forward "\nFrom: " nil t)
 108                   (setq from (buffer-substring
 109                               (point)
 110                               (save-excursion (end-of-line) (point))))
 111                 (setq from "(Unknown User)"))
 112               ;; Extract Subject:
 113               (goto-char (point-min))
 114               (if (search-forward "\nSubject: " nil t)
 115                   (setq subject (buffer-substring
 116                                  (point)
 117                                  (save-excursion (end-of-line) (point))))
 118                 (setq subject "(None)"))
 119               ;; Extract Message-ID:
 120               (goto-char (point-min))
 121               (if (search-forward "\nMessage-ID: " nil t)
 122                   (setq message-id (buffer-substring
 123                                     (point)
 124                                     (save-excursion (end-of-line) (point))))
 125                 (setq message-id nil))
 126               ;; Extract Date:
 127               (goto-char (point-min))
 128               (if (search-forward "\nDate: " nil t)
 129                   (setq date (buffer-substring
 130                               (point)
 131                               (save-excursion (end-of-line) (point))))
 132                 (setq date nil))
 133               ;; Extract Lines:
 134               (goto-char (point-min))
 135               (if (search-forward "\nLines: " nil t)
 136                   (setq lines (string-to-int
 137                                (buffer-substring
 138                                 (point)
 139                                 (save-excursion (end-of-line) (point)))))
 140                 (setq lines 0))
 141               ;; Extract Xref:
 142               (goto-char (point-min))
 143               (if (search-forward "\nXref: " nil t)
 144                   (setq xref (buffer-substring
 145                               (point)
 146                               (save-excursion (end-of-line) (point))))
 147                 (setq xref nil))
 148               ;; Extract References:
 149               ;; If no References: field, use In-Reply-To: field instead.
 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               ;; Collect valid article only.
 158               (and article
 159                    message-id
 160                    (setq headers
 161                          (cons (vector article subject from
 162                                        xref lines date
 163                                        message-id references) headers)))
 164               ))
 165         (setq sequence (cdr sequence))
 166         (setq count (1+ count))
 167         (and (numberp nntp-large-newsgroup)
 168              (> number nntp-large-newsgroup)
 169              (zerop (% count 20))
 170              (message "NNSPOOL: Receiving headers... %d%%"
 171                       (/ (* count 100) number)))
 172         )
 173       (and (numberp nntp-large-newsgroup)
 174            (> number nntp-large-newsgroup)
 175            (message "NNSPOOL: Receiving headers... done"))
 176       (nreverse headers)
 177       )))
 178
 179 \f
 180 ;;;
 181 ;;; Replacement of NNTP Raw Interface.
 182 ;;;
 183
 184 (defun nnspool-open-server (host &optional service)
 185   "Open news server on HOST.
 186 If HOST is nil, use value of environment variable `NNTPSERVER'.
 187 If optional argument SERVICE is non-nil, open by the service name."
 188   (let ((host (or host (getenv "NNTPSERVER")))
 189         (status nil))
 190     (setq nntp-status-string "")
 191     (cond ((and (file-directory-p nnspool-spool-directory)
 192                 (file-exists-p nnspool-active-file)
 193                 (string-equal host (system-name)))
 194            (setq status (nnspool-open-server-internal host service)))
 195           ((string-equal host (system-name))
 196            (setq nntp-status-string
 197                  (format "%s has no news spool.  Goodbye." host)))
 198           ((null host)
 199            (setq nntp-status-string "NNTP server is not specified."))
 200           (t
 201            (setq nntp-status-string
 202                  (format "NNSPOOL: cannot talk to %s." host)))
 203           )
 204     status
 205     ))
 206
 207 (defun nnspool-close-server ()
 208   "Close news server."
 209   (nnspool-close-server-internal))
 210
 211 (fset 'nnspool-request-quit (symbol-function 'nnspool-close-server))
 212
 213 (defun nnspool-server-opened ()
 214   "Return server process status, T or NIL.
 215 If the stream is opened, return T, otherwise return NIL."
 216   (and nntp-server-buffer
 217        (get-buffer nntp-server-buffer)))
 218
 219 (defun nnspool-status-message ()
 220   "Return server status response as string."
 221   nntp-status-string
 222   )
 223
 224 (defun nnspool-request-article (id)
 225   "Select article by message ID (or number)."
 226   (let ((file (if (stringp id)
 227                   (nnspool-find-article-by-message-id id)
 228                 (concat nnspool-current-directory (prin1-to-string id)))))
 229     (if (and (stringp file)
 230              (file-exists-p file)
 231              (not (file-directory-p file)))
 232         (save-excursion
 233           (nnspool-find-file file)))
 234     ))
 235
 236 (defun nnspool-request-body (id)
 237   "Select article body by message ID (or number)."
 238   (if (nnspool-request-article id)
 239       (save-excursion
 240         (set-buffer nntp-server-buffer)
 241         (goto-char (point-min))
 242         (if (search-forward "\n\n" nil t)
 243             (delete-region (point-min) (point)))
 244         t
 245         )
 246     ))
 247
 248 (defun nnspool-request-head (id)
 249   "Select article head by message ID (or number)."
 250   (if (nnspool-request-article id)
 251       (save-excursion
 252         (set-buffer nntp-server-buffer)
 253         (goto-char (point-min))
 254         (if (search-forward "\n\n" nil t)
 255             (delete-region (1- (point)) (point-max)))
 256         t
 257         )
 258     ))
 259
 260 (defun nnspool-request-stat (id)
 261   "Select article by message ID (or number)."
 262   (setq nntp-status-string "NNSPOOL: STAT is not implemented.")
 263   nil
 264   )
 265
 266 (defun nnspool-request-group (group)
 267   "Select news GROUP."
 268   (let ((pathname (nnspool-article-pathname
 269                    (nnspool-replace-chars-in-string group ?. ?/))))
 270     (if (file-directory-p pathname)
 271         (setq nnspool-current-directory pathname))
 272     ))
 273
 274 (defun nnspool-request-list ()
 275   "List active newsgoups."
 276   (save-excursion
 277     (nnspool-find-file nnspool-active-file)))
 278
 279 (defun nnspool-request-list-newsgroups ()
 280   "List newsgroups (defined in NNTP2)."
 281   (save-excursion
 282     (nnspool-find-file nnspool-newsgroups-file)))
 283
 284 (defun nnspool-request-list-distributions ()
 285   "List distributions (defined in NNTP2)."
 286   (save-excursion
 287     (nnspool-find-file nnspool-distributions-file)))
 288
 289 (defun nnspool-request-last ()
 290   "Set current article pointer to the previous article
 291 in the current news group."
 292   (setq nntp-status-string "NNSPOOL: LAST is not implemented.")
 293   nil
 294   )
 295
 296 (defun nnspool-request-next ()
 297   "Advance current article pointer."
 298   (setq nntp-status-string "NNSPOOL: NEXT is not implemented.")
 299   nil
 300   )
 301
 302 (defun nnspool-request-post ()
 303   "Post a new news in current buffer."
 304   (save-excursion
 305     ;; We have to work in the server buffer because of NEmacs hack.
 306     (copy-to-buffer nntp-server-buffer (point-min) (point-max))
 307     (set-buffer nntp-server-buffer)
 308     (apply (function call-process-region)
 309            (point-min) (point-max)
 310            nnspool-inews-program 'delete t nil nnspool-inews-switches)
 311     (prog1
 312         (or (zerop (buffer-size))
 313             ;; If inews returns strings, it must be error message
 314             ;;  unless SPOOLNEWS is defined.
 315             ;; This condition is very weak, but there is no good rule
 316             ;;  identifying errors when SPOOLNEWS is defined.
 317             ;; Suggested by ohm@kaba.junet.
 318             (string-match "spooled" (buffer-string)))
 319       ;; Make status message by unfolding lines.
 320       (subst-char-in-region (point-min) (point-max) ?\n ?\\ 'noundo)
 321       (setq nntp-status-string (buffer-string))
 322       (erase-buffer))
 323     ))
 324
 325 \f
 326 ;;;
 327 ;;; Replacement of Low-Level Interface to NNTP Server.
 328 ;;;
 329
 330 (defun nnspool-open-server-internal (host &optional service)
 331   "Open connection to news server on HOST by SERVICE (default is nntp)."
 332   (save-excursion
 333     (if (not (string-equal host (system-name)))
 334         (error "NNSPOOL: cannot talk to %s." host))
 335     ;; Initialize communication buffer.
 336     (setq nntp-server-buffer (get-buffer-create " *nntpd*"))
 337     (set-buffer nntp-server-buffer)
 338     (buffer-flush-undo (current-buffer))
 339     (erase-buffer)
 340     (kill-all-local-variables)
 341     (setq case-fold-search t)           ;Should ignore case.
 342     (setq nntp-server-process nil)
 343     (setq nntp-server-name host)
 344     ;; It is possible to change kanji-fileio-code in this hook.
 345     (run-hooks 'nntp-server-hook)
 346     t
 347     ))
 348
 349 (defun nnspool-close-server-internal ()
 350   "Close connection to news server."
 351   (if (get-file-buffer nnspool-history-file)
 352       (kill-buffer (get-file-buffer nnspool-history-file)))
 353   (if nntp-server-buffer
 354       (kill-buffer nntp-server-buffer))
 355   (setq nntp-server-buffer nil)
 356   (setq nntp-server-process nil))
 357
 358 (defun nnspool-find-article-by-message-id (id)
 359   "Return full pathname of an article identified by message-ID."
 360   (save-excursion
 361     (let ((buffer (get-file-buffer nnspool-history-file)))
 362       (if buffer
 363           (set-buffer buffer)
 364         ;; Finding history file may take lots of time.
 365         (message "Reading history file...")
 366         (set-buffer (find-file-noselect nnspool-history-file))
 367         (message "Reading history file... done")))
 368     ;; Search from end of the file. I think this is much faster than
 369     ;; do from the beginning of the file.
 370     (goto-char (point-max))
 371     (if (re-search-backward
 372          (concat "^" (regexp-quote id)
 373                  "[ \t].*[ \t]\\([^ \t/]+\\)/\\([0-9]+\\)[ \t]*$") nil t)
 374         (let ((group (buffer-substring (match-beginning 1) (match-end 1)))
 375               (number (buffer-substring (match-beginning 2) (match-end 2))))
 376           (concat (nnspool-article-pathname
 377                    (nnspool-replace-chars-in-string group ?. ?/))
 378                   number))
 379       )))
 380
 381 (defun nnspool-find-file (file)
 382   "Insert FILE in server buffer safely."
 383   (set-buffer nntp-server-buffer)
 384   (erase-buffer)
 385   (condition-case ()
 386       (progn (insert-file-contents file) t)
 387     (file-error nil)
 388     ))
 389
 390 (defun nnspool-article-pathname (group)
 391   "Make pathname for GROUP."
 392   (concat (file-name-as-directory nnspool-spool-directory) group "/"))
 393
 394 (defun nnspool-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 occurrences 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     ))
 406
 407 (provide 'nnspool)
 408
 409 ;;; nnspool.el ends here