lisp/nnspool.el

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