Mercurial > emacs
changeset 87:d39407c00c09
Initial revision
| author | root <root> |
|---|---|
| date | Thu, 30 Aug 1990 07:55:32 +0000 |
| parents | 278f3b6206cc |
| children | b3c75acda8a8 |
| files | lisp/=mhspool.el lisp/=nnspool.el lisp/=nntp.el |
| diffstat | 3 files changed, 1448 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/=mhspool.el Thu Aug 30 07:55:32 1990 +0000 @@ -0,0 +1,405 @@ +;;; MH folder access using NNTP for GNU Emacs +;; Copyright (C) 1988, 1989 Fujitsu Laboratories LTD. +;; Copyright (C) 1988, 1989, 1990 Masanobu UMEDA +;; $Header: mhspool.el,v 1.5 90/03/23 13:25:23 umerin Locked $ + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + +(provide 'mhspool) +(require 'nntp) + +;; This package enables you to read mail or articles in MH folders, or +;; articles saved by GNUS. In any case, the file names of mail or +;; articles must consist of only numeric letters. + +;; Before using this package, you have to create a server specific +;; startup file according to the directory which you want to read. For +;; example, if you want to read mail under the directory named +;; `~/Mail', the file must be a file named `.newsrc-:Mail'. (There is +;; no way to specify hierarchical directory now.) In this case, the +;; name of the NNTP server passed to GNUS must be `:Mail'. + +(defvar mhspool-list-directory-switches '("-R") + "*Switches for nntp-request-list to pass to `ls' for gettting file lists. +One entry should appear on one line. You may need to add `-1' option.") + + + +(defconst mhspool-version "MHSPOOL 1.5" + "Version numbers of this version of MHSPOOL.") + +(defvar mhspool-spool-directory "~/Mail" + "Private mail directory.") + +(defvar mhspool-current-directory nil + "Current news group directory.") + +;;; +;;; Replacement of Extended Command for retrieving many headers. +;;; + +(defun mhspool-retrieve-headers (sequence) + "Return list of article headers specified by SEQUENCE of article id. +The format of list is + `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'. +Reader macros for the vector are defined as `nntp-header-FIELD'. +Writer macros for the vector are defined as `nntp-set-header-FIELD'. +News group must be selected before calling me." + (save-excursion + (set-buffer nntp-server-buffer) + ;;(erase-buffer) + (let ((file nil) + (number (length sequence)) + (count 0) + (headers nil) ;Result list. + (article 0) + (subject nil) + (message-id nil) + (from nil) + (xref nil) + (lines 0) + (date nil) + (references nil)) + (while sequence + ;;(nntp-send-strings-to-server "HEAD" (car sequence)) + (setq article (car sequence)) + (setq file + (concat mhspool-current-directory (prin1-to-string article))) + (if (and (file-exists-p file) + (not (file-directory-p file))) + (progn + (erase-buffer) + (insert-file-contents file) + ;; Make message body invisible. + (goto-char (point-min)) + (search-forward "\n\n" nil 'move) + (narrow-to-region (point-min) (point)) + ;; Fold continuation lines. + (goto-char (point-min)) + (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) + (replace-match " " t t)) + ;; Make it possible to search for `\nFIELD'. + (goto-char (point-min)) + (insert "\n") + ;; Extract From: + (goto-char (point-min)) + (if (search-forward "\nFrom: " nil t) + (setq from (buffer-substring + (point) + (save-excursion (end-of-line) (point)))) + (setq from "(Unknown User)")) + ;; Extract Subject: + (goto-char (point-min)) + (if (search-forward "\nSubject: " nil t) + (setq subject (buffer-substring + (point) + (save-excursion (end-of-line) (point)))) + (setq subject "(None)")) + ;; Extract Message-ID: + (goto-char (point-min)) + (if (search-forward "\nMessage-ID: " nil t) + (setq message-id (buffer-substring + (point) + (save-excursion (end-of-line) (point)))) + (setq message-id nil)) + ;; Extract Date: + (goto-char (point-min)) + (if (search-forward "\nDate: " nil t) + (setq date (buffer-substring + (point) + (save-excursion (end-of-line) (point)))) + (setq date nil)) + ;; Extract Lines: + (goto-char (point-min)) + (if (search-forward "\nLines: " nil t) + (setq lines (string-to-int + (buffer-substring + (point) + (save-excursion (end-of-line) (point))))) + (setq lines 0)) + ;; Extract Xref: + (goto-char (point-min)) + (if (search-forward "\nXref: " nil t) + (setq xref (buffer-substring + (point) + (save-excursion (end-of-line) (point)))) + (setq xref nil)) + ;; Extract References: + ;; If no References: field, use In-Reply-To: field instead. + ;; Suggested by tanaka@flab.fujitsu.co.jp (Hiroshi TANAKA). + (goto-char (point-min)) + (if (or (search-forward "\nReferences: " nil t) + (search-forward "\nIn-Reply-To: " nil t)) + (setq references (buffer-substring + (point) + (save-excursion (end-of-line) (point)))) + (setq references nil)) + (setq headers + (cons (vector article subject from + xref lines date + message-id references) headers)) + )) + (setq sequence (cdr sequence)) + (setq count (1+ count)) + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (zerop (% count 20)) + (message "MHSPOOL: %d%% of headers received." + (/ (* count 100) number))) + ) + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (message "MHSPOOL: 100%% of headers received.")) + (nreverse headers) + ))) + + +;;; +;;; Replacement of NNTP Raw Interface. +;;; + +(defun mhspool-open-server (host &optional service) + "Open news server on HOST. +If HOST is nil, use value of environment variable `NNTPSERVER'. +If optional argument SERVICE is non-nil, open by the service name." + (let ((host (or host (getenv "NNTPSERVER"))) + (status nil)) + ;; Get directory name from HOST name. + (if (string-match ":\\(.+\\)$" host) + (progn + (setq mhspool-spool-directory + (file-name-as-directory + (expand-file-name + (substring host (match-beginning 1) (match-end 1)) + (expand-file-name "~/" nil)))) + (setq host (system-name))) + (setq mhspool-spool-directory nil)) + (setq nntp-status-message-string "") + (cond ((and (stringp host) + (stringp mhspool-spool-directory) + (file-directory-p mhspool-spool-directory) + (string-equal host (system-name))) + (setq status (mhspool-open-server-internal host service))) + ((string-equal host (system-name)) + (setq nntp-status-message-string + (format "No such directory: %s. Goodbye." + mhspool-spool-directory))) + ((null host) + (setq nntp-status-message-string "NNTP server is not specified.")) + (t + (setq nntp-status-message-string + (format "MHSPOOL: cannot talk to %s." host))) + ) + status + )) + +(defun mhspool-close-server () + "Close news server." + (mhspool-close-server-internal)) + +(fset 'mhspool-request-quit (symbol-function 'mhspool-close-server)) + +(defun mhspool-server-opened () + "Return server process status, T or NIL. +If the stream is opened, return T, otherwise return NIL." + (and nntp-server-buffer + (get-buffer nntp-server-buffer))) + +(defun mhspool-status-message () + "Return server status response as string." + nntp-status-message-string + ) + +(defun mhspool-request-article (id) + "Select article by message ID (or number)." + (let ((file (concat mhspool-current-directory (prin1-to-string id)))) + (if (and (stringp file) + (file-exists-p file) + (not (file-directory-p file))) + (save-excursion + (mhspool-find-file file))) + )) + +(defun mhspool-request-body (id) + "Select article body by message ID (or number)." + (if (mhspool-request-article id) + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (delete-region (point-min) (point))) + t + ) + )) + +(defun mhspool-request-head (id) + "Select article head by message ID (or number)." + (if (mhspool-request-article id) + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (delete-region (1- (point)) (point-max))) + t + ) + )) + +(defun mhspool-request-stat (id) + "Select article by message ID (or number)." + (error "MHSPOOL: STAT is not implemented.")) + +(defun mhspool-request-group (group) + "Select news GROUP." + (cond ((file-directory-p + (mhspool-article-pathname group)) + ;; Mail/NEWS.GROUP/N + (setq mhspool-current-directory + (mhspool-article-pathname group))) + ((file-directory-p + (mhspool-article-pathname + (mhspool-replace-chars-in-string group ?. ?/))) + ;; Mail/NEWS/GROUP/N + (setq mhspool-current-directory + (mhspool-article-pathname + (mhspool-replace-chars-in-string group ?. ?/)))) + )) + +(defun mhspool-request-list () + "List valid newsgoups." + (save-excursion + (let* ((newsgroup nil) + (articles nil) + (directory (file-name-as-directory + (expand-file-name mhspool-spool-directory nil))) + (folder-regexp (concat "^" (regexp-quote directory) "\\(.+\\):$")) + (buffer (get-buffer-create " *GNUS file listing*"))) + (set-buffer nntp-server-buffer) + (erase-buffer) + (set-buffer buffer) + (erase-buffer) + (apply 'call-process + "ls" nil t nil + (append mhspool-list-directory-switches (list directory))) + (goto-char (point-min)) + (while (re-search-forward folder-regexp nil t) + (setq newsgroup + (mhspool-replace-chars-in-string + (buffer-substring (match-beginning 1) (match-end 1)) ?/ ?.)) + (setq articles nil) + (forward-line 1) ;(beginning-of-line) + ;; Thank nobu@flab.fujitsu.junet for his bug fixes. + (while (and (not (eobp)) + (not (looking-at "^$"))) + (if (looking-at "^[0-9]+$") + (setq articles + (cons (string-to-int + (buffer-substring + (match-beginning 0) (match-end 0))) + articles))) + (forward-line 1)) + (if articles + (princ (format "%s %d %d n\n" newsgroup + (apply (function max) articles) + (apply (function min) articles)) + nntp-server-buffer)) + ) + (kill-buffer buffer) + (set-buffer nntp-server-buffer) + (buffer-size) + ))) + +(defun mhspool-request-last () + "Set current article pointer to the previous article +in the current news group." + (error "MHSPOOL: LAST is not implemented.")) + +(defun mhspool-request-next () + "Advance current article pointer." + (error "MHSPOOL: NEXT is not implemented.")) + +(defun mhspool-request-post () + "Post a new news in current buffer." + (setq nntp-status-message-string "MHSPOOL: what do you mean post?") + nil + ) + + +;;; +;;; Replacement of Low-Level Interface to NNTP Server. +;;; + +(defun mhspool-open-server-internal (host &optional service) + "Open connection to news server on HOST by SERVICE (default is nntp)." + (save-excursion + (if (not (string-equal host (system-name))) + (error "MHSPOOL: cannot talk to %s." host)) + ;; Initialize communication buffer. + (setq nntp-server-buffer (get-buffer-create " *nntpd*")) + (set-buffer nntp-server-buffer) + (buffer-flush-undo (current-buffer)) + (erase-buffer) + (kill-all-local-variables) + (setq case-fold-search t) ;Should ignore case. + (setq nntp-server-process nil) + (setq nntp-server-name host) + ;; It is possible to change kanji-fileio-code in this hook. + (run-hooks 'nntp-server-hook) + t + )) + +(defun mhspool-close-server-internal () + "Close connection to news server." + (if nntp-server-buffer + (kill-buffer nntp-server-buffer)) + (setq nntp-server-buffer nil) + (setq nntp-server-process nil)) + +(defun mhspool-find-file (file) + "Insert FILE in server buffer safely." + (set-buffer nntp-server-buffer) + (erase-buffer) + (condition-case () + (progn + (insert-file-contents file) + (goto-char (point-min)) + ;; If there is no body, `^L' appears at end of file. Special + ;; hack for MH folder. + (and (search-forward "\n\n" nil t) + (string-equal (buffer-substring (point) (point-max)) "\^L") + (delete-char 1)) + t + ) + (file-error nil) + )) + +(defun mhspool-article-pathname (group) + "Make pathname for GROUP." + (concat (file-name-as-directory mhspool-spool-directory) group "/")) + +(defun mhspool-replace-chars-in-string (string from to) + "Replace characters in STRING from FROM to TO." + (let ((string (substring string 0)) ;Copy string. + (len (length string)) + (idx 0)) + ;; Replace all occurence of FROM with TO. + (while (< idx len) + (if (= (aref string idx) from) + (aset string idx to)) + (setq idx (1+ idx))) + string + ))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/=nnspool.el Thu Aug 30 07:55:32 1990 +0000 @@ -0,0 +1,375 @@ +;;; Spool access using NNTP for GNU Emacs +;; Copyright (C) 1988, 1989 Fujitsu Laboratories LTD. +;; Copyright (C) 1988, 1989, 1990 Masanobu UMEDA +;; $Header: nnspool.el,v 1.10 90/03/23 13:25:25 umerin Locked $ + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + +(provide 'nnspool) +(require 'nntp) + +(defvar nnspool-inews-program news-inews-program + "*Program to post news.") + +(defvar nnspool-inews-switches '("-h") + "*Switches for nnspool-request-post to pass to `inews' for posting news.") + +(defvar nnspool-spool-directory news-path + "*Local news spool directory.") + +(defvar nnspool-active-file "/usr/lib/news/active" + "*Local news active file.") + +(defvar nnspool-history-file "/usr/lib/news/history" + "*Local news history file.") + + + +(defconst nnspool-version "NNSPOOL 1.10" + "Version numbers of this version of NNSPOOL.") + +(defvar nnspool-current-directory nil + "Current news group directory.") + +;;; +;;; Replacement of Extended Command for retrieving many headers. +;;; + +(defun nnspool-retrieve-headers (sequence) + "Return list of article headers specified by SEQUENCE of article id. +The format of list is + `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'. +Reader macros for the vector are defined as `nntp-header-FIELD'. +Writer macros for the vector are defined as `nntp-set-header-FIELD'. +News group must be selected before calling me." + (save-excursion + (set-buffer nntp-server-buffer) + ;;(erase-buffer) + (let ((file nil) + (number (length sequence)) + (count 0) + (headers nil) ;Result list. + (article 0) + (subject nil) + (message-id nil) + (from nil) + (xref nil) + (lines 0) + (date nil) + (references nil)) + (while sequence + ;;(nntp-send-strings-to-server "HEAD" (car sequence)) + (setq article (car sequence)) + (setq file + (concat nnspool-current-directory (prin1-to-string article))) + (if (and (file-exists-p file) + (not (file-directory-p file))) + (progn + (erase-buffer) + (insert-file-contents file) + ;; Make message body invisible. + (goto-char (point-min)) + (search-forward "\n\n" nil 'move) + (narrow-to-region (point-min) (point)) + ;; Fold continuation lines. + (goto-char (point-min)) + (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) + (replace-match " " t t)) + ;; Make it possible to search for `\nFIELD'. + (goto-char (point-min)) + (insert "\n") + ;; Extract From: + (goto-char (point-min)) + (if (search-forward "\nFrom: " nil t) + (setq from (buffer-substring + (point) + (save-excursion (end-of-line) (point)))) + (setq from "(Unknown User)")) + ;; Extract Subject: + (goto-char (point-min)) + (if (search-forward "\nSubject: " nil t) + (setq subject (buffer-substring + (point) + (save-excursion (end-of-line) (point)))) + (setq subject "(None)")) + ;; Extract Message-ID: + (goto-char (point-min)) + (if (search-forward "\nMessage-ID: " nil t) + (setq message-id (buffer-substring + (point) + (save-excursion (end-of-line) (point)))) + (setq message-id nil)) + ;; Extract Date: + (goto-char (point-min)) + (if (search-forward "\nDate: " nil t) + (setq date (buffer-substring + (point) + (save-excursion (end-of-line) (point)))) + (setq date nil)) + ;; Extract Lines: + (goto-char (point-min)) + (if (search-forward "\nLines: " nil t) + (setq lines (string-to-int + (buffer-substring + (point) + (save-excursion (end-of-line) (point))))) + (setq lines 0)) + ;; Extract Xref: + (goto-char (point-min)) + (if (search-forward "\nXref: " nil t) + (setq xref (buffer-substring + (point) + (save-excursion (end-of-line) (point)))) + (setq xref nil)) + ;; Extract References: + (goto-char (point-min)) + (if (search-forward "\nReferences: " nil t) + (setq references (buffer-substring + (point) + (save-excursion (end-of-line) (point)))) + (setq references nil)) + (setq headers + (cons (vector article subject from + xref lines date + message-id references) headers)) + )) + (setq sequence (cdr sequence)) + (setq count (1+ count)) + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (zerop (% count 20)) + (message "NNSPOOL: %d%% of headers received." + (/ (* count 100) number))) + ) + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (message "NNSPOOL: 100%% of headers received.")) + (nreverse headers) + ))) + + +;;; +;;; Replacement of NNTP Raw Interface. +;;; + +(defun nnspool-open-server (host &optional service) + "Open news server on HOST. +If HOST is nil, use value of environment variable `NNTPSERVER'. +If optional argument SERVICE is non-nil, open by the service name." + (let ((host (or host (getenv "NNTPSERVER"))) + (status nil)) + (setq nntp-status-message-string "") + (cond ((and (file-directory-p nnspool-spool-directory) + (file-exists-p nnspool-active-file) + (string-equal host (system-name))) + (setq status (nnspool-open-server-internal host service))) + ((string-equal host (system-name)) + (setq nntp-status-message-string + (format "%s has no news spool. Goodbye." host))) + ((null host) + (setq nntp-status-message-string "NNTP server is not specified.")) + (t + (setq nntp-status-message-string + (format "NNSPOOL: cannot talk to %s." host))) + ) + status + )) + +(defun nnspool-close-server () + "Close news server." + (nnspool-close-server-internal)) + +(fset 'nnspool-request-quit (symbol-function 'nnspool-close-server)) + +(defun nnspool-server-opened () + "Return server process status, T or NIL. +If the stream is opened, return T, otherwise return NIL." + (and nntp-server-buffer + (get-buffer nntp-server-buffer))) + +(defun nnspool-status-message () + "Return server status response as string." + nntp-status-message-string + ) + +(defun nnspool-request-article (id) + "Select article by message ID (or number)." + (let ((file (if (stringp id) + (nnspool-find-article-by-message-id id) + (concat nnspool-current-directory (prin1-to-string id))))) + (if (and (stringp file) + (file-exists-p file) + (not (file-directory-p file))) + (save-excursion + (nnspool-find-file file))) + )) + +(defun nnspool-request-body (id) + "Select article body by message ID (or number)." + (if (nnspool-request-article id) + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (delete-region (point-min) (point))) + t + ) + )) + +(defun nnspool-request-head (id) + "Select article head by message ID (or number)." + (if (nnspool-request-article id) + (save-excursion + (set-buffer nntp-server-buffer) + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (delete-region (1- (point)) (point-max))) + t + ) + )) + +(defun nnspool-request-stat (id) + "Select article by message ID (or number)." + (error "NNSPOOL: STAT is not implemented.")) + +(defun nnspool-request-group (group) + "Select news GROUP." + (let ((pathname (nnspool-article-pathname + (nnspool-replace-chars-in-string group ?. ?/)))) + (if (file-directory-p pathname) + (setq nnspool-current-directory pathname)) + )) + +(defun nnspool-request-list () + "List valid newsgoups." + (save-excursion + (nnspool-find-file nnspool-active-file))) + +(defun nnspool-request-last () + "Set current article pointer to the previous article +in the current news group." + (error "NNSPOOL: LAST is not implemented.")) + +(defun nnspool-request-next () + "Advance current article pointer." + (error "NNSPOOL: NEXT is not implemented.")) + +(defun nnspool-request-post () + "Post a new news in current buffer." + (save-excursion + ;; We have to work in the server buffer because of NEmacs hack. + (copy-to-buffer nntp-server-buffer (point-min) (point-max)) + (set-buffer nntp-server-buffer) + (apply 'call-process-region + (point-min) (point-max) + nnspool-inews-program 'delete t nil nnspool-inews-switches) + (prog1 + (or (zerop (buffer-size)) + ;; If inews returns strings, it must be error message + ;; unless SPOOLNEWS is defined. + ;; This condition is very weak, but there is no good rule + ;; identifying errors when SPOOLNEWS is defined. + ;; Suggested by ohm@kaba.junet. + (string-match "spooled" (buffer-string))) + ;; Make status message by unfolding lines. + (subst-char-in-region (point-min) (point-max) ?\n ?\\ 'noundo) + (setq nntp-status-message-string (buffer-string)) + (erase-buffer)) + )) + + +;;; +;;; Replacement of Low-Level Interface to NNTP Server. +;;; + +(defun nnspool-open-server-internal (host &optional service) + "Open connection to news server on HOST by SERVICE (default is nntp)." + (save-excursion + (if (not (string-equal host (system-name))) + (error "NNSPOOL: cannot talk to %s." host)) + ;; Initialize communication buffer. + (setq nntp-server-buffer (get-buffer-create " *nntpd*")) + (set-buffer nntp-server-buffer) + (buffer-flush-undo (current-buffer)) + (erase-buffer) + (kill-all-local-variables) + (setq case-fold-search t) ;Should ignore case. + (setq nntp-server-process nil) + (setq nntp-server-name host) + ;; It is possible to change kanji-fileio-code in this hook. + (run-hooks 'nntp-server-hook) + t + )) + +(defun nnspool-close-server-internal () + "Close connection to news server." + (if (get-file-buffer nnspool-history-file) + (kill-buffer (get-file-buffer nnspool-history-file))) + (if nntp-server-buffer + (kill-buffer nntp-server-buffer)) + (setq nntp-server-buffer nil) + (setq nntp-server-process nil)) + +(defun nnspool-find-article-by-message-id (id) + "Return full pathname of an artilce identified by message-ID." + (save-excursion + (let ((buffer (get-file-buffer nnspool-history-file))) + (if buffer + (set-buffer buffer) + ;; Finding history file may take lots of time. + (message "Reading history file...") + (set-buffer (find-file-noselect nnspool-history-file)) + (message "Reading history file... done"))) + ;; Search from end of the file. I think this is much faster than + ;; do from the beginning of the file. + (goto-char (point-max)) + (if (re-search-backward + (concat "^" (regexp-quote id) + "[ \t].*[ \t]\\([^ \t/]+\\)/\\([0-9]+\\)[ \t]*$") nil t) + (let ((group (buffer-substring (match-beginning 1) (match-end 1))) + (number (buffer-substring (match-beginning 2) (match-end 2)))) + (concat (nnspool-article-pathname + (nnspool-replace-chars-in-string group ?. ?/)) + number)) + ))) + +(defun nnspool-find-file (file) + "Insert FILE in server buffer safely." + (set-buffer nntp-server-buffer) + (erase-buffer) + (condition-case () + (progn (insert-file-contents file) t) + (file-error nil) + )) + +(defun nnspool-article-pathname (group) + "Make pathname for GROUP." + (concat (file-name-as-directory nnspool-spool-directory) group "/")) + +(defun nnspool-replace-chars-in-string (string from to) + "Replace characters in STRING from FROM to TO." + (let ((string (substring string 0)) ;Copy string. + (len (length string)) + (idx 0)) + ;; Replace all occurence of FROM with TO. + (while (< idx len) + (if (= (aref string idx) from) + (aset string idx to)) + (setq idx (1+ idx))) + string + ))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/=nntp.el Thu Aug 30 07:55:32 1990 +0000 @@ -0,0 +1,668 @@ +;;; NNTP (RFC977) Interface for GNU Emacs +;; Copyright (C) 1987, 1988, 1989 Fujitsu Laboratories LTD. +;; Copyright (C) 1987, 1988, 1989, 1990 Masanobu UMEDA +;; $Header: nntp.el,v 3.10 90/03/23 13:25:27 umerin Locked $ + +;; This file is part of GNU Emacs. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY. No author or distributor +;; accepts responsibility to anyone for the consequences of using it +;; or for whether it serves any particular purpose or works at all, +;; unless he says so in writing. Refer to the GNU Emacs General Public +;; License for full details. + +;; Everyone is granted permission to copy, modify and redistribute +;; GNU Emacs, but only under the conditions described in the +;; GNU Emacs General Public License. A copy of this license is +;; supposed to have been given to you along with GNU Emacs so you +;; can know your rights and responsibilities. It should be in a +;; file named COPYING. Among other things, the copyright notice +;; and this notice must be preserved on all copies. + +;; This implementation is tested on both 1.2a and 1.5 version of the +;; NNTP package. + +;; Troubleshooting of NNTP +;; +;; (1) Select routine may signal an error or fall into infinite loop +;; while waiting for the server response. In this case, you'd better +;; not use byte-compiled codes but original source. If you still have +;; a problems with it, set the variable `nntp-buggy-select' to T. +;; +;; (2) Emacs may hang up while retrieving headers since too many +;; requests have been sent to the NNTP server without reading their +;; replies. In this case, reduce the number of the requests sent to +;; the server at one time by setting the variable +;; `nntp-maximum-request' to a lower value. +;; +;; (3) If the TCP/IP stream (open-network-stream) is not supported by +;; emacs, compile and install `tcp.el' and `tcp.c' which is an +;; emulation program of the stream. If you modified `tcp.c' for your +;; system, please send me the diffs. I'll include some of them in the +;; future releases. + +(provide 'nntp) + +(defvar nntp-server-hook nil + "*Hooks for the NNTP server. +If the kanji code of the NNTP server is different from the local kanji +code, the correct kanji code of the buffer associated with the NNTP +server must be specified as follows: + +(setq nntp-server-hook + '(lambda () + ;; Server's Kanji code is EUC (NEmacs hack). + (make-local-variable 'kanji-fileio-code) + (setq kanji-fileio-code 0))) + +If you'd like to change something depending on the server in this +hook, use the variable `nntp-server-name'.") + +(defvar nntp-buggy-select (memq system-type '(usg-unix-v fujitsu-uts)) + "*T if your select routine is buggy. +If the select routine signals error or fall into infinite loop while +waiting for the server response, the variable must be set to t. In +case of Fujitsu UTS, it is set to T since `accept-process-output' +doesn't work properly.") + +(defvar nntp-maximum-request 400 + "*The maximum number of the requests sent to the NNTP server at one time. +If Emacs hangs up while retrieving headers, set the variable to a +lower value.") + +(defvar nntp-large-newsgroup 50 + "*The number of the articles which indicates a large newsgroup. +If the number of the articles is greater than the value, verbose +messages will be shown to indicate the current status.") + + +(defconst nntp-version "NNTP 3.10" + "Version numbers of this version of NNTP.") + +(defvar nntp-server-name nil + "The name of the host running NNTP server.") + +(defvar nntp-server-buffer nil + "Buffer associated with NNTP server process.") + +(defvar nntp-server-process nil + "The NNTP server process. +You'd better not use this variable in NNTP front-end program but +instead use `nntp-server-buffer'.") + +(defvar nntp-status-message-string nil + "Save the server response message. +You'd better not use this variable in NNTP front-end program but +instead call function `nntp-status-message' to get status message.") + +;;; +;;; Extended Command for retrieving many headers. +;;; +;; Retrieving lots of headers by sending command asynchronously. +;; Access functions to headers are defined as macro. + +(defmacro nntp-header-number (header) + "Return article number in HEADER." + (` (aref (, header) 0))) + +(defmacro nntp-set-header-number (header number) + "Set article number of HEADER to NUMBER." + (` (aset (, header) 0 (, number)))) + +(defmacro nntp-header-subject (header) + "Return subject string in HEADER." + (` (aref (, header) 1))) + +(defmacro nntp-set-header-subject (header subject) + "Set article subject of HEADER to SUBJECT." + (` (aset (, header) 1 (, subject)))) + +(defmacro nntp-header-from (header) + "Return author string in HEADER." + (` (aref (, header) 2))) + +(defmacro nntp-set-header-from (header from) + "Set article author of HEADER to FROM." + (` (aset (, header) 2 (, from)))) + +(defmacro nntp-header-xref (header) + "Return xref string in HEADER." + (` (aref (, header) 3))) + +(defmacro nntp-set-header-xref (header xref) + "Set article xref of HEADER to xref." + (` (aset (, header) 3 (, xref)))) + +(defmacro nntp-header-lines (header) + "Return lines in HEADER." + (` (aref (, header) 4))) + +(defmacro nntp-set-header-lines (header lines) + "Set article lines of HEADER to LINES." + (` (aset (, header) 4 (, lines)))) + +(defmacro nntp-header-date (header) + "Return date in HEADER." + (` (aref (, header) 5))) + +(defmacro nntp-set-header-date (header date) + "Set article date of HEADER to DATE." + (` (aset (, header) 5 (, date)))) + +(defmacro nntp-header-id (header) + "Return Id in HEADER." + (` (aref (, header) 6))) + +(defmacro nntp-set-header-id (header id) + "Set article Id of HEADER to ID." + (` (aset (, header) 6 (, id)))) + +(defmacro nntp-header-references (header) + "Return references in HEADER." + (` (aref (, header) 7))) + +(defmacro nntp-set-header-references (header ref) + "Set article references of HEADER to REF." + (` (aset (, header) 7 (, ref)))) + +(defun nntp-retrieve-headers (sequence) + "Return list of article headers specified by SEQUENCE of article id. +The format of list is + `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'. +Reader macros for the vector are defined as `nntp-header-FIELD'. +Writer macros for the vector are defined as `nntp-set-header-FIELD'. +News group must be selected before calling me." + (save-excursion + (set-buffer nntp-server-buffer) + (erase-buffer) + (let ((number (length sequence)) + (last-point (point-min)) + (received 0) + (count 0) + (headers nil) ;Result list. + (article 0) + (subject nil) + (message-id) + (from nil) + (xref nil) + (lines 0) + (date nil) + (references nil)) + ;; Send HEAD command. + (while sequence + (nntp-send-strings-to-server "HEAD" (car sequence)) + (setq sequence (cdr sequence)) + (setq count (1+ count)) + ;; Every 400 header requests we have to read stream in order + ;; to avoid deadlock. + (if (or (null sequence) ;All requests have been sent. + (zerop (% count nntp-maximum-request))) + (progn + (accept-process-output) + (while (progn + (goto-char last-point) + ;; Count replies. + (while (re-search-forward "^[0-9]" nil t) + (setq received (1+ received))) + (setq last-point (point)) + (< received count)) + ;; If number of headers is greater than 100, give + ;; informative messages. + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (zerop (% received 20)) + (message "NNTP: %d%% of headers received." + (/ (* received 100) number))) + (nntp-accept-response)) + )) + ) + ;; Wait for text of last command. + (goto-char (point-max)) + (re-search-backward "^[0-9]" nil t) + (if (looking-at "^[23]") + (while (progn + (goto-char (- (point-max) 3)) + (not (looking-at "^\\.\r$"))) + (nntp-accept-response))) + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (message "NNTP: 100%% of headers received.")) + ;; Now all of replies are received. + (setq received number) + ;; First, fold continuation lines. + (goto-char (point-min)) + (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t) + (replace-match " " t t)) + ;;(delete-non-matching-lines + ;; "^Subject:\\|^Xref:\\|^From:\\|^Lines:\\|^Date:\\|^References:\\|^[23]") + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (message "NNTP: Parsing headers...")) + ;; Then examines replies. + (goto-char (point-min)) + (while (not (eobp)) + (cond ((looking-at "^[23][0-9][0-9][ \t]+\\([0-9]+\\)[ \t]+\\(<[^>]+>\\)") + (setq article + (string-to-int + (buffer-substring (match-beginning 1) (match-end 1)))) + (setq message-id + (buffer-substring (match-beginning 2) (match-end 2))) + (forward-line 1) + ;; Set default value. + (setq subject nil) + (setq xref nil) + (setq from nil) + (setq lines 0) + (setq date nil) + (setq references nil) + ;; Thanks go to mly@AI.MIT.EDU (Richard Mlynarik) + (while (and (not (eobp)) + (not (memq (following-char) '(?2 ?3)))) + (if (looking-at "\\(From\\|Subject\\|Date\\|Lines\\|Xref\\|References\\):[ \t]+\\([^ \t\n]+.*\\)\r$") + (let ((s (buffer-substring + (match-beginning 2) (match-end 2))) + (c (char-after (match-beginning 0)))) + ;; We don't have to worry about letter case. + (cond ((char-equal c ?F) ;From: + (setq from s)) + ((char-equal c ?S) ;Subject: + (setq subject s)) + ((char-equal c ?D) ;Date: + (setq date s)) + ((char-equal c ?L) ;Lines: + (setq lines (string-to-int s))) + ((char-equal c ?X) ;Xref: + (setq xref s)) + ((char-equal c ?R) ;References: + (setq references s)) + ))) + (forward-line 1)) + ;; Finished to parse one header. + (if (null subject) + (setq subject "(None)")) + (if (null from) + (setq from "(Unknown User)")) + (setq headers + (cons (vector article subject from + xref lines date + message-id references) headers)) + ) + (t (forward-line 1)) + ) + (setq received (1- received)) + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (zerop (% received 20)) + (message "NNTP: Parsing headers... %d%%" + (/ (* received 100) number))) + ) + (and (numberp nntp-large-newsgroup) + (> number nntp-large-newsgroup) + (message "NNTP: Parsing headers... done")) + (nreverse headers) + ))) + + +;;; +;;; Raw Interface to Network News Transfer Protocol (RFC977). +;;; + +(defun nntp-open-server (host &optional service) + "Open news server on HOST. +If HOST is nil, use value of environment variable `NNTPSERVER'. +If optional argument SERVICE is non-nil, open by the service name." + (let ((host (or host (getenv "NNTPSERVER"))) + (status nil)) + (setq nntp-status-message-string "") + (cond ((and host (nntp-open-server-internal host service)) + (setq status (nntp-wait-for-response "^[23].*\r$")) + ;; Do check unexpected close of connection. + ;; Suggested by feldmark@hanako.stars.flab.fujitsu.junet. + (if status + (set-process-sentinel nntp-server-process + 'nntp-default-sentinel) + ;; We have to close connection here, since function + ;; `nntp-server-opened' may return incorrect status. + (nntp-close-server-internal) + )) + ((null host) + (setq nntp-status-message-string "NNTP server is not specified.")) + ) + status + )) + +(defun nntp-close-server () + "Close news server." + (unwind-protect + (progn + ;; Un-set default sentinel function before closing connection. + (and nntp-server-process + (eq 'nntp-default-sentinel + (process-sentinel nntp-server-process)) + (set-process-sentinel nntp-server-process nil)) + ;; We cannot send QUIT command unless the process is running. + (if (nntp-server-opened) + (nntp-send-command nil "QUIT")) + ) + (nntp-close-server-internal) + )) + +(fset 'nntp-request-quit (symbol-function 'nntp-close-server)) + +(defun nntp-server-opened () + "Return server process status, T or NIL. +If the stream is opened, return T, otherwise return NIL." + (and nntp-server-process + (memq (process-status nntp-server-process) '(open run)))) + +(defun nntp-status-message () + "Return server status response as string." + (if (and nntp-status-message-string + ;; NNN MESSAGE + (string-match "[0-9][0-9][0-9][ \t]+\\([^\r]*\\).*$" + nntp-status-message-string)) + (substring nntp-status-message-string (match-beginning 1) (match-end 1)) + ;; Empty message if nothing. + "" + )) + +(defun nntp-request-article (id) + "Select article by message ID (or number)." + (prog1 + ;; If NEmacs, end of message may look like: "\256\215" (".^M") + (nntp-send-command "^\\.\r$" "ARTICLE" id) + (nntp-decode-text) + )) + +(defun nntp-request-body (id) + "Select article body by message ID (or number)." + (prog1 + ;; If NEmacs, end of message may look like: "\256\215" (".^M") + (nntp-send-command "^\\.\r$" "BODY" id) + (nntp-decode-text) + )) + +(defun nntp-request-head (id) + "Select article head by message ID (or number)." + (prog1 + (nntp-send-command "^\\.\r$" "HEAD" id) + (nntp-decode-text) + )) + +(defun nntp-request-stat (id) + "Select article by message ID (or number)." + (nntp-send-command "^[23].*\r$" "STAT" id)) + +(defun nntp-request-group (group) + "Select news GROUP." + ;; 1.2a NNTP's group command is buggy. "^M" (\r) is not appended to + ;; end of the status message. + (nntp-send-command "^[23].*$" "GROUP" group)) + +(defun nntp-request-list () + "List valid newsgoups." + (prog1 + (nntp-send-command "^\\.\r$" "LIST") + (nntp-decode-text) + )) + +(defun nntp-request-last () + "Set current article pointer to the previous article +in the current news group." + (nntp-send-command "^[23].*\r$" "LAST")) + +(defun nntp-request-next () + "Advance current article pointer." + (nntp-send-command "^[23].*\r$" "NEXT")) + +(defun nntp-request-post () + "Post a new news in current buffer." + (if (nntp-send-command "^[23].*\r$" "POST") + (progn + (nntp-encode-text) + (nntp-send-region-to-server (point-min) (point-max)) + ;; 1.2a NNTP's post command is buggy. "^M" (\r) is not + ;; appended to end of the status message. + (nntp-wait-for-response "^[23].*$") + ))) + +(defun nntp-default-sentinel (proc status) + "Default sentinel function for NNTP server process." + (if (and nntp-server-process + (not (nntp-server-opened))) + (error "NNTP: Connection closed.") + )) + +;; Encoding and decoding of NNTP text. + +(defun nntp-decode-text () + "Decode text transmitted by NNTP. +0. Delete status line. +1. Delete `^M' at end of line. +2. Delete `.' at end of buffer (end of text mark). +3. Delete `.' at beginning of line." + (save-excursion + (set-buffer nntp-server-buffer) + ;; Insert newline at end of buffer. + (goto-char (point-max)) + (if (not (bolp)) + (insert "\n")) + ;; Delete status line. + (goto-char (point-min)) + (delete-region (point) (progn (forward-line 1) (point))) + ;; Delete `^M' at end of line. + ;; (replace-regexp "\r$" "") + (while (not (eobp)) + (end-of-line) + (if (= (preceding-char) ?\r) + (delete-char -1)) + (forward-line 1) + ) + ;; Delete `.' at end of buffer (end of text mark). + (goto-char (point-max)) + (forward-line -1) ;(beginning-of-line) + (if (looking-at "^\\.$") + (delete-region (point) (progn (forward-line 1) (point)))) + ;; Replace `..' at beginning of line with `.'. + (goto-char (point-min)) + ;; (replace-regexp "^\\.\\." ".") + (while (search-forward "\n.." nil t) + (delete-char -1)) + )) + +(defun nntp-encode-text () + "Encode text in current buffer for NNTP transmission. +1. Insert `.' at beginning of line. +2. Insert `.' at end of buffer (end of text mark)." + (save-excursion + ;; Insert newline at end of buffer. + (goto-char (point-max)) + (if (not (bolp)) + (insert "\n")) + ;; Replace `.' at beginning of line with `..'. + (goto-char (point-min)) + ;; (replace-regexp "^\\." "..") + (while (search-forward "\n." nil t) + (insert ".")) + ;; Insert `.' at end of buffer (end of text mark). + (goto-char (point-max)) + (insert ".\n") + )) + + +;;; +;;; Synchronous Communication with NNTP Server. +;;; + +(defun nntp-send-command (response cmd &rest args) + "Wait for server RESPONSE after sending CMD and optional ARGS to server." + (save-excursion + ;; Clear communication buffer. + (set-buffer nntp-server-buffer) + (erase-buffer) + (apply 'nntp-send-strings-to-server cmd args) + (if response + (nntp-wait-for-response response) + t) + )) + +(defun nntp-wait-for-response (regexp) + "Wait for server response which matches REGEXP." + (save-excursion + (let ((status t) + (wait t)) + (set-buffer nntp-server-buffer) + ;; Wait for status response (RFC977). + ;; 1xx - Informative message. + ;; 2xx - Command ok. + ;; 3xx - Command ok so far, send the rest of it. + ;; 4xx - Command was correct, but couldn't be performed for some + ;; reason. + ;; 5xx - Command unimplemented, or incorrect, or a serious + ;; program error occurred. + (nntp-accept-response) + (while wait + (goto-char (point-min)) + (cond ((looking-at "[23]") + (setq wait nil)) + ((looking-at "[45]") + (setq status nil) + (setq wait nil)) + (t (nntp-accept-response)) + )) + ;; Save status message. + (end-of-line) + (setq nntp-status-message-string + (buffer-substring (point-min) (point))) + (if status + (progn + (setq wait t) + (while wait + (goto-char (point-max)) + (forward-line -1) ;(beginning-of-line) + ;;(message (buffer-substring + ;; (point) + ;; (save-excursion (end-of-line) (point)))) + (if (looking-at regexp) + (setq wait nil) + (message "NNTP: Reading...") + (nntp-accept-response) + (message "") + )) + ;; Successfully received server response. + t + )) + ))) + + +;;; +;;; Low-Level Interface to NNTP Server. +;;; + +(defun nntp-send-strings-to-server (&rest strings) + "Send list of STRINGS to news server as command and its arguments." + (let ((cmd (car strings)) + (strings (cdr strings))) + ;; Command and each argument must be separeted by one or more spaces. + (while strings + (setq cmd (concat cmd " " (car strings))) + (setq strings (cdr strings))) + ;; Command line must be terminated by a CR-LF. + (process-send-string nntp-server-process (concat cmd "\n")) + )) + +(defun nntp-send-region-to-server (begin end) + "Send current buffer region (from BEGIN to END) to news server." + (save-excursion + ;; We have to work in the buffer associated with NNTP server + ;; process because of NEmacs hack. + (copy-to-buffer nntp-server-buffer begin end) + (set-buffer nntp-server-buffer) + (setq begin (point-min)) + (setq end (point-max)) + ;; `process-send-region' does not work if text to be sent is very + ;; large. I don't know maximum size of text sent correctly. + (let ((last nil) + (size 100)) ;Size of text sent at once. + (save-restriction + (narrow-to-region begin end) + (goto-char begin) + (while (not (eobp)) + ;;(setq last (min end (+ (point) size))) + ;; NEmacs gets confused if character at `last' is Kanji. + (setq last (save-excursion + (goto-char (min end (+ (point) size))) + (or (eobp) (forward-char 1)) ;Adjust point + (point))) + (process-send-region nntp-server-process (point) last) + ;; I don't know whether the next codes solve the known + ;; problem of communication error of GNU Emacs. + (accept-process-output) + ;;(sit-for 0) + (goto-char last) + ))) + ;; We cannot erase buffer, because reply may be received. + (delete-region begin end) + )) + +(defun nntp-open-server-internal (host &optional service) + "Open connection to news server on HOST by SERVICE (default is nntp)." + (save-excursion + ;; Use TCP/IP stream emulation package if needed. + (or (fboundp 'open-network-stream) + (require 'tcp)) + ;; Initialize communication buffer. + (setq nntp-server-buffer (get-buffer-create " *nntpd*")) + (set-buffer nntp-server-buffer) + (buffer-flush-undo (current-buffer)) + (erase-buffer) + (kill-all-local-variables) + (setq case-fold-search t) ;Should ignore case. + (setq nntp-server-process + (open-network-stream "nntpd" (current-buffer) + host (or service "nntp"))) + (setq nntp-server-name host) + ;; It is possible to change kanji-fileio-code in this hook. + (run-hooks 'nntp-server-hook) + ;; Return the server process. + nntp-server-process + )) + +(defun nntp-close-server-internal () + "Close connection to news server." + (if nntp-server-process + (delete-process nntp-server-process)) + (if nntp-server-buffer + (kill-buffer nntp-server-buffer)) + (setq nntp-server-buffer nil) + (setq nntp-server-process nil)) + +(defun nntp-accept-response () + "Read response of server. +It is well-known that the communication speed will be much improved by +defining this function as macro." + ;; To deal with server process exiting before + ;; accept-process-output is called. + ;; Suggested by Jason Venner <jason@violet.berkeley.edu>. + ;; This is a copy of `nntp-default-sentinel'. + (or (memq (process-status nntp-server-process) '(open run)) + (error "NNTP: Connection closed.")) + (if nntp-buggy-select + (progn + ;; We cannot use `accept-process-output'. + ;; Fujitsu UTS requires messages during sleep-for. I don't know why. + (message "NNTP: Reading...") + (sleep-for 1) + (message "")) + (condition-case errorcode + (accept-process-output nntp-server-process) + (error + (cond ((string-equal "select error: Invalid argument" (nth 1 errorcode)) + ;; Ignore select error. + nil + ) + (t + (signal (car errorcode) (cdr errorcode)))) + )) + ))