lisp/nnspool.el

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