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