home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / gnus / nnspool.el < prev    next >
Encoding:
Text File  |  1992-08-18  |  11.7 KB  |  375 lines
  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.  
  5. ;; This file is part of GNU Emacs.
  6.  
  7. ;; GNU Emacs is distributed in the hope that it will be useful,
  8. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  9. ;; accepts responsibility to anyone for the consequences of using it
  10. ;; or for whether it serves any particular purpose or works at all,
  11. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  12. ;; License for full details.
  13.  
  14. ;; Everyone is granted permission to copy, modify and redistribute
  15. ;; GNU Emacs, but only under the conditions described in the
  16. ;; GNU Emacs General Public License.   A copy of this license is
  17. ;; supposed to have been given to you along with GNU Emacs so you
  18. ;; can know your rights and responsibilities.  It should be in a
  19. ;; file named COPYING.  Among other things, the copyright notice
  20. ;; and this notice must be preserved on all copies.
  21.  
  22. (provide 'nnspool)
  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.  
  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.  
  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-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-string
  182.          (format "%s has no news spool.  Goodbye." host)))
  183.       ((null host)
  184.        (setq nntp-status-string "NNTP server is not specified."))
  185.       (t
  186.        (setq nntp-status-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-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
  264. 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-string (buffer-string))
  291.       (erase-buffer))
  292.     ))
  293.  
  294.  
  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-disable-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 artilce 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.     ))
  375.