diff options
Diffstat (limited to 'lisp/nntp.el')
| -rw-r--r-- | lisp/nntp.el | 667 |
1 files changed, 0 insertions, 667 deletions
diff --git a/lisp/nntp.el b/lisp/nntp.el deleted file mode 100644 index 6bb7a741076..00000000000 --- a/lisp/nntp.el +++ /dev/null @@ -1,667 +0,0 @@ -;;; 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)))) - )) - )) |