X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fnntp.el;fp=lisp%2Fnntp.el;h=0000000000000000000000000000000000000000;hb=b369cf058148bbe6dee0154df7bcc2a7c0cc63d0;hp=215750f323de6db860ed2698a8b585a96c3dee15;hpb=73430ac519bb1723c621b7b393a1e37c949e4c16;p=elisp%2Fgnus.git- diff --git a/lisp/nntp.el b/lisp/nntp.el deleted file mode 100644 index 215750f..0000000 --- a/lisp/nntp.el +++ /dev/null @@ -1,1725 +0,0 @@ -;;; nntp.el --- nntp access for Gnus -;; Copyright (C) 1987, 1988, 1989, 1990, 1992, 1993, 1994, 1995, 1996, -;; 1997, 1998, 2000, 2001 -;; Free Software Foundation, Inc. - -;; Author: Lars Magne Ingebrigtsen -;; Katsumi Yamaoka -;; Keywords: news - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;;; Code: - -(eval-when-compile (require 'cl)) -(eval-when-compile (require 'gnus-clfns)) - -(require 'nnheader) -(require 'nnoo) -(require 'gnus-util) - -(nnoo-declare nntp) - -(defvoo nntp-address nil - "Address of the physical nntp server.") - -(defvoo nntp-port-number "nntp" - "Port number on the physical nntp server.") - -(defvoo nntp-list-options nil - "List of newsgroup name used for a option of the LIST command to -restrict the listing output to only the specified newsgroups. -Each newsgroup name can be a shell-style wildcard, for instance, -\"fj.*\", \"japan.*\", etc. Fortunately, if the server can accept -such a option, it will probably make gnus run faster. You may -use it as a server variable as follows: - -\(setq gnus-select-method - '(nntp \"news.somewhere.edu\" - (nntp-list-options (\"fj.*\" \"japan.*\"))))") - -(defvoo nntp-options-subscribe nil - "Regexp matching the newsgroup names which will be subscribed -unconditionally. It may be effective as well as `nntp-list-options' -even though the server could not accept a shell-style wildcard as a -option of the LIST command. You may use it as a server variable as -follows: - -\(setq gnus-select-method - '(nntp \"news.somewhere.edu\" - (nntp-options-subscribe \"^fj\\\\.\\\\|^japan\\\\.\")))") - -(defvoo nntp-options-not-subscribe nil - "Regexp matching the newsgroup names which will not be subscribed -unconditionally. It may be effective as well as `nntp-list-options' -even though the server could not accept a shell-style wildcard as a -option of the LIST command. You may use it as a server variable as -follows: - -\(setq gnus-select-method - '(nntp \"news.somewhere.edu\" - (nntp-options-not-subscribe \"\\\\.binaries\\\\.\")))") - -(defvoo nntp-server-opened-hook '(nntp-send-mode-reader) - "*Hook used for sending commands to the server at startup. -The default value is `nntp-send-mode-reader', which makes an innd -server spawn an nnrpd server.") - -(defvoo nntp-authinfo-function 'nntp-send-authinfo - "Function used to send AUTHINFO to the server. -It is called with no parameters.") - -(defvoo nntp-server-action-alist - '(("nntpd 1\\.5\\.11t" - (remove-hook 'nntp-server-opened-hook 'nntp-send-mode-reader)) - ("NNRP server Netscape" - (setq nntp-server-list-active-group nil))) - "Alist of regexps to match on server types and actions to be taken. -For instance, if you want Gnus to beep every time you connect -to innd, you could say something like: - -\(setq nntp-server-action-alist - '((\"innd\" (ding)))) - -You probably don't want to do that, though.") - -(defvoo nntp-open-connection-function 'nntp-open-network-stream - "*Function used for connecting to a remote system. -It will be called with the buffer to output in as argument. - -Currently, five such functions are provided (please refer to their -respective doc string for more information), three of them establishing -direct connections to the nntp server, and two of them using an indirect -host. - -Direct connections: -- `nntp-open-network-stream' (the default), -- `nntp-open-ssl-stream', -- `nntp-open-telnet-stream'. - -Indirect connections: -- `nntp-open-via-rlogin-and-telnet', -- `nntp-open-via-telnet-and-telnet'.") - -(defvoo nntp-pre-command nil - "*Pre-command to use with the various nntp-open-via-* methods. -This is where you would put \"runsocks\" or stuff like that.") - -(defvoo nntp-telnet-command "telnet" - "*Telnet command used to connect to the nntp server. -This command is used by the various nntp-open-via-* methods.") - -(defvoo nntp-telnet-switches '("-8") - "*Switches given to the telnet command `nntp-telnet-command'.") - -(defvoo nntp-end-of-line "\r\n" - "*String to use on the end of lines when talking to the NNTP server. -This is \"\\r\\n\" by default, but should be \"\\n\" when -using and indirect connection method (nntp-open-via-*).") - -(defvoo nntp-via-rlogin-command "rsh" - "*Rlogin command used to connect to an intermediate host. -This command is used by the `nntp-open-via-rlogin-and-telnet' method. -The default is \"rsh\", but \"ssh\" is a popular alternative.") - -(defvoo nntp-via-telnet-command "telnet" - "*Telnet command used to connect to an intermediate host. -This command is used by the `nntp-open-via-telnet-and-telnet' method.") - -(defvoo nntp-via-telnet-switches '("-8") - "*Switches given to the telnet command `nntp-via-telnet-command'.") - -(defvoo nntp-via-user-name nil - "*User name to log in on an intermediate host with. -This variable is used by the `nntp-open-via-telnet-and-telnet' method.") - -(defvoo nntp-via-user-password nil - "*Password to use to log in on an intermediate host with. -This variable is used by the `nntp-open-via-telnet-and-telnet' method.") - -(defvoo nntp-via-address nil - "*Address of an intermediate host to connect to. -This variable is used by the `nntp-open-via-rlogin-and-telnet' and -`nntp-open-via-telnet-and-telnet' methods.") - -(defvoo nntp-via-envuser nil - "*Whether both telnet client and server support the ENVIRON option. -If non-nil, there will be no prompt for a login name.") - -(defvoo nntp-via-shell-prompt "bash\\|\$ *\r?$\\|> *\r?" - "*Regular expression to match the shell prompt on an intermediate host. -This variable is used by the `nntp-open-via-telnet-and-telnet' method.") - -(defvoo 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.") - -(defvoo 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.") - -(defvoo nntp-nov-is-evil nil - "*If non-nil, nntp will never attempt to use XOVER when talking to the server.") - -(defvoo nntp-xover-commands '("XOVER" "XOVERVIEW") - "*List of strings that are used as commands to fetch NOV lines from a server. -The strings are tried in turn until a positive response is gotten. If -none of the commands are successful, nntp will just grab headers one -by one.") - -(defvoo nntp-nov-gap 5 - "*Maximum allowed gap between two articles. -If the gap between two consecutive articles is bigger than this -variable, split the XOVER request into two requests.") - -(defvoo nntp-prepare-server-hook nil - "*Hook run before a server is opened. -If can be used to set up a server remotely, for instance. Say you -have an account at the machine \"other.machine\". This machine has -access to an NNTP server that you can't access locally. You could -then use this hook to rsh to the remote machine and start a proxy NNTP -server there that you can connect to. See also -`nntp-open-connection-function'") - -(defvoo nntp-warn-about-losing-connection t - "*If non-nil, beep when a server closes connection.") - -(defcustom nntp-authinfo-file "~/.authinfo" - ".netrc-like file that holds nntp authinfo passwords." - :type - '(choice file - (repeat :tag "Entries" - :menu-tag "Inline" - (list :format "%v" - :value ("" ("login" . "") ("password" . "")) - (string :tag "Host") - (checklist :inline t - (cons :format "%v" - (const :format "" "login") - (string :format "Login: %v")) - (cons :format "%v" - (const :format "" "password") - (string :format "Password: %v"))))))) - - - -(defvoo nntp-connection-timeout nil - "*Number of seconds to wait before an nntp connection times out. -If this variable is nil, which is the default, no timers are set. -NOTE: This variable is never seen to work in Emacs 20 and XEmacs 21.") - -(defvoo nntp-prepare-post-hook nil - "*Hook run just before posting an article. It is supposed to be used for -inserting Cancel-Lock headers, signing with Gpg, etc.") - -;;; Internal variables. - -(defvar nntp-record-commands nil - "*If non-nil, nntp will record all commands in the \"*nntp-log*\" buffer.") - -(defvar nntp-have-messaged nil) - -(defvar nntp-process-wait-for nil) -(defvar nntp-process-to-buffer nil) -(defvar nntp-process-callback nil) -(defvar nntp-process-decode nil) -(defvar nntp-process-start-point nil) -(defvar nntp-inside-change-function nil) -(defvoo nntp-last-command-time nil) -(defvoo nntp-last-command nil) -(defvoo nntp-authinfo-password nil) -(defvoo nntp-authinfo-user nil) - -(defvar nntp-connection-list nil) - -(defvoo nntp-server-type nil) -(defvoo nntp-connection-alist nil) -(defvoo nntp-status-string "") -(defconst nntp-version "nntp 5.0") -(defvoo nntp-inhibit-erase nil) -(defvoo nntp-inhibit-output nil) - -(defvoo nntp-server-xover 'try) -(defvoo nntp-server-list-active-group 'try) - -(defvar nntp-async-needs-kluge - (string-match "^GNU Emacs 20\\.3\\." (emacs-version)) - "*When non-nil, nntp will poll asynchronous connections -once a second. By default, this is turned on only for Emacs -20.3, which has a bug that breaks nntp's normal method of -noticing asynchronous data.") - -(defvar nntp-async-timer nil) -(defvar nntp-async-process-list nil) - -(eval-and-compile - (autoload 'mail-source-read-passwd "mail-source") - (autoload 'open-ssl-stream "ssl")) - - - -;;; Internal functions. - -(defsubst nntp-send-string (process string) - "Send STRING to PROCESS." - ;; We need to store the time to provide timeouts, and - ;; to store the command so the we can replay the command - ;; if the server gives us an AUTHINFO challenge. - (setq nntp-last-command-time (current-time) - nntp-last-command string) - (when nntp-record-commands - (nntp-record-command string)) - (process-send-string process (concat string nntp-end-of-line))) - -(defun nntp-record-command (string) - "Record the command STRING." - (save-excursion - (set-buffer (get-buffer-create "*nntp-log*")) - (goto-char (point-max)) - (let ((time (current-time))) - (insert (format-time-string "%Y%m%dT%H%M%S" time) - "." (format "%03d" (/ (nth 2 time) 1000)) - " " nntp-address " " string "\n")))) - -(defsubst nntp-wait-for (process wait-for buffer &optional decode discard) - "Wait for WAIT-FOR to arrive from PROCESS." - (save-excursion - (set-buffer (process-buffer process)) - (goto-char (point-min)) - (while (and (or (not (memq (char-after (point)) '(?2 ?3 ?4 ?5))) - (looking-at "480")) - (memq (process-status process) '(open run))) - (when (looking-at "480") - (nntp-handle-authinfo process)) - (when (looking-at "^.*\n") - (delete-region (point) (progn (forward-line 1) (point)))) - (nntp-accept-process-output process) - (goto-char (point-min))) - (prog1 - (cond - ((looking-at "[45]") - (progn - (nntp-snarf-error-message) - nil)) - ((not (memq (process-status process) '(open run))) - (nnheader-report 'nntp "Server closed connection")) - (t - (goto-char (point-max)) - (let ((limit (point-min)) - response) - (while (not (re-search-backward wait-for limit t)) - (nntp-accept-process-output process) - ;; We assume that whatever we wait for is less than 1000 - ;; characters long. - (setq limit (max (- (point-max) 1000) (point-min))) - (goto-char (point-max))) - (setq response (match-string 0)) - (save-current-buffer - (set-buffer nntp-server-buffer) - (setq nntp-process-response response))) - (nntp-decode-text (not decode)) - (unless discard - (save-excursion - (set-buffer buffer) - (goto-char (point-max)) - (insert-buffer-substring (process-buffer process)) - ;; Nix out "nntp reading...." message. - (when nntp-have-messaged - (setq nntp-have-messaged nil) - (nnheader-message 5 "")))) - t)) - (unless discard - (erase-buffer))))) - -(defun nntp-kill-buffer (buffer) - (when (buffer-name buffer) - (kill-buffer buffer) - (nnheader-init-server-buffer))) - -(defsubst nntp-find-connection (buffer) - "Find the connection delivering to BUFFER." - (let ((alist nntp-connection-alist) - (buffer (if (stringp buffer) (get-buffer buffer) buffer)) - process entry) - (while (and alist (setq entry (pop alist))) - (when (eq buffer (cadr entry)) - (setq process (car entry) - alist nil))) - (when process - (if (memq (process-status process) '(open run)) - process - (nntp-kill-buffer (process-buffer process)) - (setq nntp-connection-alist (delq entry nntp-connection-alist)) - nil)))) - -(defsubst nntp-find-connection-entry (buffer) - "Return the entry for the connection to BUFFER." - (assq (nntp-find-connection buffer) nntp-connection-alist)) - -(defun nntp-find-connection-buffer (buffer) - "Return the process connection buffer tied to BUFFER." - (let ((process (nntp-find-connection buffer))) - (when process - (process-buffer process)))) - -(defsubst nntp-retrieve-data (command address port buffer - &optional wait-for callback decode) - "Use COMMAND to retrieve data into BUFFER from PORT on ADDRESS." - (let ((process (or (nntp-find-connection buffer) - (nntp-open-connection buffer)))) - (if (not process) - (nnheader-report 'nntp "Couldn't open connection to %s" address) - (unless (or nntp-inhibit-erase nnheader-callback-function) - (save-excursion - (set-buffer (process-buffer process)) - (erase-buffer))) - (condition-case err - (progn - (when command - (nntp-send-string process command)) - (cond - ((eq callback 'ignore) - t) - ((and callback wait-for) - (nntp-async-wait process wait-for buffer decode callback) - t) - (wait-for - (nntp-wait-for process wait-for buffer decode)) - (t t))) - (error - (nnheader-report 'nntp "Couldn't open connection to %s: %s" - address err)) - (quit - (message "Quit retrieving data from nntp") - (signal 'quit nil) - nil))))) - -(defsubst nntp-send-command (wait-for &rest strings) - "Send STRINGS to server and wait until WAIT-FOR returns." - (when (and (not nnheader-callback-function) - (not nntp-inhibit-output)) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer))) - (let* ((command (mapconcat 'identity strings " ")) - (buffer (process-buffer (nntp-find-connection nntp-server-buffer))) - (pos (with-current-buffer buffer (point)))) - (prog1 - (nntp-retrieve-data command - nntp-address nntp-port-number nntp-server-buffer - wait-for nnheader-callback-function) - ;; If nothing to wait for, still remove possibly echo'ed commands - (unless wait-for - (nntp-accept-response) - (save-excursion - (set-buffer buffer) - (goto-char pos) - (if (looking-at (regexp-quote command)) - (delete-region pos (progn (forward-line 1) (gnus-point-at-bol)))) - ))) - )) - -(defun nntp-send-command-nodelete (wait-for &rest strings) - "Send STRINGS to server and wait until WAIT-FOR returns." - (let* ((command (mapconcat 'identity strings " ")) - (buffer (process-buffer (nntp-find-connection nntp-server-buffer))) - (pos (with-current-buffer buffer (point)))) - (prog1 - (nntp-retrieve-data command - nntp-address nntp-port-number nntp-server-buffer - wait-for nnheader-callback-function) - ;; If nothing to wait for, still remove possibly echo'ed commands - (unless wait-for - (nntp-accept-response) - (save-excursion - (set-buffer buffer) - (goto-char pos) - (if (looking-at (regexp-quote command)) - (delete-region pos (progn (forward-line 1) (gnus-point-at-bol)))) - ))) - )) - -(defun nntp-send-command-and-decode (wait-for &rest strings) - "Send STRINGS to server and wait until WAIT-FOR returns." - (when (and (not nnheader-callback-function) - (not nntp-inhibit-output)) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer))) - (let* ((command (mapconcat 'identity strings " ")) - (buffer (process-buffer (nntp-find-connection nntp-server-buffer))) - (pos (with-current-buffer buffer (point)))) - (prog1 - (nntp-retrieve-data command - nntp-address nntp-port-number nntp-server-buffer - wait-for nnheader-callback-function t) - ;; If nothing to wait for, still remove possibly echo'ed commands - (unless wait-for - (nntp-accept-response) - (save-excursion - (set-buffer buffer) - (goto-char pos) - (if (looking-at (regexp-quote command)) - (delete-region pos (progn (forward-line 1) (gnus-point-at-bol)))) - ))) - )) - - -(defun nntp-send-buffer (wait-for) - "Send the current buffer to server and wait until WAIT-FOR returns." - (when (and (not nnheader-callback-function) - (not nntp-inhibit-output)) - (save-excursion - (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) - (erase-buffer))) - (nntp-encode-text) - (process-send-region (nntp-find-connection nntp-server-buffer) - (point-min) (point-max)) - (nntp-retrieve-data - nil nntp-address nntp-port-number nntp-server-buffer - wait-for nnheader-callback-function)) - - - -;;; Interface functions. - -(nnoo-define-basics nntp) - -(defsubst nntp-next-result-arrived-p () - (cond - ;; A result that starts with a 2xx code is terminated by - ;; a line with only a "." on it. - ((eq (char-after) ?2) - (if (re-search-forward "\n\\.\r?\n" nil t) - t - nil)) - ;; A result that starts with a 3xx or 4xx code is terminated - ;; by a newline. - ((looking-at "[34]") - (if (search-forward "\n" nil t) - t - nil)) - ;; No result here. - (t - nil))) - -(deffoo nntp-retrieve-headers (articles &optional group server fetch-old) - "Retrieve the headers of ARTICLES." - (nntp-possibly-change-group group server) - (save-excursion - (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) - (erase-buffer) - (if (and (not gnus-nov-is-evil) - (not nntp-nov-is-evil) - (nntp-retrieve-headers-with-xover articles fetch-old)) - ;; We successfully retrieved the headers via XOVER. - 'nov - ;; XOVER didn't work, so we do it the hard, slow and inefficient - ;; way. - (let ((number (length articles)) - (count 0) - (received 0) - (last-point (point-min)) - (buf (nntp-find-connection-buffer nntp-server-buffer)) - (nntp-inhibit-erase t) - article) - ;; Send HEAD commands. - (while (setq article (pop articles)) - (nntp-send-command - nil - "HEAD" (if (numberp article) - (int-to-string article) - ;; `articles' is either a list of article numbers - ;; or a list of article IDs. - article)) - (incf count) - ;; Every 400 requests we have to read the stream in - ;; order to avoid deadlocks. - (when (or (null articles) ;All requests have been sent. - (zerop (% count nntp-maximum-request))) - (nntp-accept-response) - (while (progn - (set-buffer buf) - (goto-char last-point) - ;; Count replies. - (while (nntp-next-result-arrived-p) - (setq last-point (point)) - (incf received)) - (< 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)) - (nnheader-message 6 "NNTP: Receiving headers... %d%%" - (/ (* received 100) number))) - (nntp-accept-response)))) - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (nnheader-message 6 "NNTP: Receiving headers...done")) - - ;; Now all of replies are received. Fold continuation lines. - (nnheader-fold-continuation-lines) - ;; Remove all "\r"'s. - (nnheader-strip-cr) - (copy-to-buffer nntp-server-buffer (point-min) (point-max)) - 'headers)))) - -(deffoo nntp-retrieve-groups (groups &optional server) - "Retrieve group info on GROUPS." - (nntp-possibly-change-group nil server) - (when (nntp-find-connection-buffer nntp-server-buffer) - (catch 'done - (save-excursion - ;; Erase nntp-server-buffer before nntp-inhibit-erase. - (set-buffer nntp-server-buffer) - (erase-buffer) - (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) - ;; The first time this is run, this variable is `try'. So we - ;; try. - (when (eq nntp-server-list-active-group 'try) - (nntp-try-list-active (car groups))) - (erase-buffer) - (let ((count 0) - (received 0) - (last-point (point-min)) - (nntp-inhibit-erase t) - (buf (nntp-find-connection-buffer nntp-server-buffer)) - (command (if nntp-server-list-active-group "LIST ACTIVE" "GROUP"))) - (while groups - ;; Send the command to the server. - (nntp-send-command nil command (pop groups)) - (incf count) - ;; Every 400 requests we have to read the stream in - ;; order to avoid deadlocks. - (when (or (null groups) ;All requests have been sent. - (zerop (% count nntp-maximum-request))) - (nntp-accept-response) - (while (and (gnus-buffer-live-p buf) - (progn - ;; Search `blue moon' in this file for the - ;; reason why set-buffer here. - (set-buffer buf) - (goto-char last-point) - ;; Count replies. - (while (re-search-forward "^[0-9]" nil t) - (incf received)) - (setq last-point (point)) - (< received count))) - (nntp-accept-response)))) - - ;; Wait for the reply from the final command. - (unless (gnus-buffer-live-p buf) - (nnheader-report 'nntp "Connection to %s is closed." server) - (throw 'done nil)) - (set-buffer buf) - (goto-char (point-max)) - (re-search-backward "^[0-9]" nil t) - (when (looking-at "^[23]") - (while (and (gnus-buffer-live-p buf) - (progn - (set-buffer buf) - (goto-char (point-max)) - (if (not nntp-server-list-active-group) - (not (re-search-backward "\r?\n" (- (point) 3) t)) - (not (re-search-backward "^\\.\r?\n" - (- (point) 4) t))))) - (nntp-accept-response))) - - ;; Now all replies are received. We remove CRs. - (unless (gnus-buffer-live-p buf) - (nnheader-report 'nntp "Connection to %s is closed." server) - (throw 'done nil)) - (set-buffer buf) - (goto-char (point-min)) - (while (search-forward "\r" nil t) - (replace-match "" t t)) - - (if (not nntp-server-list-active-group) - (progn - (copy-to-buffer nntp-server-buffer (point-min) (point-max)) - 'group) - ;; We have read active entries, so we just delete the - ;; superfluous gunk. - (goto-char (point-min)) - (while (re-search-forward "^[.2-5]" nil t) - (delete-region (match-beginning 0) - (progn (forward-line 1) (point)))) - (copy-to-buffer nntp-server-buffer (point-min) (point-max)) - 'active)))))) - -(deffoo nntp-retrieve-articles (articles &optional group server) - (nntp-possibly-change-group group server) - (save-excursion - (let ((number (length articles)) - (count 0) - (received 0) - (last-point (point-min)) - (buf (nntp-find-connection-buffer nntp-server-buffer)) - (nntp-inhibit-erase t) - (map (apply 'vector articles)) - (point 1) - article) - (set-buffer buf) - (erase-buffer) - ;; Send ARTICLE command. - (while (setq article (pop articles)) - (nntp-send-command - nil - "ARTICLE" (if (numberp article) - (int-to-string article) - ;; `articles' is either a list of article numbers - ;; or a list of article IDs. - article)) - (incf count) - ;; Every 400 requests we have to read the stream in - ;; order to avoid deadlocks. - (when (or (null articles) ;All requests have been sent. - (zerop (% count nntp-maximum-request))) - (nntp-accept-response) - (while (progn - (set-buffer buf) - (goto-char last-point) - ;; Count replies. - (while (nntp-next-result-arrived-p) - (aset map received (cons (aref map received) (point))) - (setq last-point (point)) - (incf received)) - (< 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)) - (nnheader-message 6 "NNTP: Receiving articles... %d%%" - (/ (* received 100) number))) - (nntp-accept-response)))) - (and (numberp nntp-large-newsgroup) - (> number nntp-large-newsgroup) - (nnheader-message 6 "NNTP: Receiving articles...done")) - - ;; Now we have all the responses. We go through the results, - ;; wash it and copy it over to the server buffer. - (set-buffer nntp-server-buffer) - (erase-buffer) - (setq last-point (point-min)) - (mapcar - (lambda (entry) - (narrow-to-region - (setq point (goto-char (point-max))) - (progn - (insert-buffer-substring buf last-point (cdr entry)) - (point-max))) - (setq last-point (cdr entry)) - (nntp-decode-text) - (widen) - (cons (car entry) point)) - map)))) - -(defun nntp-try-list-active (group) - (nntp-list-active-group group) - (save-excursion - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (cond ((or (eobp) - (looking-at "5[0-9]+")) - (setq nntp-server-list-active-group nil)) - (t - (setq nntp-server-list-active-group t))))) - -(deffoo nntp-list-active-group (group &optional server) - "Return the active info on GROUP (which can be a regexp)." - (nntp-possibly-change-group nil server) - (nntp-send-command "^\\.*\r?\n" "LIST ACTIVE" group)) - -(deffoo nntp-request-group-articles (group &optional server) - "Return the list of existing articles in GROUP." - (nntp-possibly-change-group nil server) - (nntp-send-command "^\\.*\r?\n" "LISTGROUP" group)) - -(deffoo nntp-request-article (article &optional group server buffer command) - (nntp-possibly-change-group group server) - (when (nntp-send-command-and-decode - "\r?\n\\.\r?\n" "ARTICLE" - (if (numberp article) (int-to-string article) article)) - (if (and buffer - (not (equal buffer nntp-server-buffer))) - (save-excursion - (set-buffer nntp-server-buffer) - (copy-to-buffer buffer (point-min) (point-max)) - (nntp-find-group-and-number)) - (nntp-find-group-and-number)))) - -(deffoo nntp-request-head (article &optional group server) - (nntp-possibly-change-group group server) - (when (nntp-send-command - "\r?\n\\.\r?\n" "HEAD" - (if (numberp article) (int-to-string article) article)) - (prog1 - (nntp-find-group-and-number) - (nntp-decode-text)))) - -(deffoo nntp-request-body (article &optional group server) - (nntp-possibly-change-group group server) - (nntp-send-command-and-decode - "\r?\n\\.\r?\n" "BODY" - (if (numberp article) (int-to-string article) article))) - -(deffoo nntp-request-group (group &optional server dont-check) - (nntp-possibly-change-group nil server) - (when (nntp-send-command "^[245].*\n" "GROUP" group) - (let ((entry (nntp-find-connection-entry nntp-server-buffer))) - (setcar (cddr entry) group)))) - -(deffoo nntp-close-group (group &optional server) - t) - -(deffoo nntp-server-opened (&optional server) - "Say whether a connection to SERVER has been opened." - (and (nnoo-current-server-p 'nntp server) - nntp-server-buffer - (gnus-buffer-live-p nntp-server-buffer) - (nntp-find-connection nntp-server-buffer))) - -(deffoo nntp-open-server (server &optional defs connectionless) - (nnheader-init-server-buffer) - (if (nntp-server-opened server) - t - (when (or (stringp (car defs)) - (numberp (car defs))) - (setq defs (cons (list 'nntp-port-number (car defs)) (cdr defs)))) - (unless (assq 'nntp-address defs) - (setq defs (append defs (list (list 'nntp-address server))))) - (nnoo-change-server 'nntp server defs) - (unless connectionless - (or (nntp-find-connection nntp-server-buffer) - (nntp-open-connection nntp-server-buffer))))) - -(deffoo nntp-close-server (&optional server) - (nntp-possibly-change-group nil server t) - (let ((process (nntp-find-connection nntp-server-buffer))) - (while process - (when (memq (process-status process) '(open run)) - (ignore-errors - (nntp-send-string process "QUIT") - (unless (eq nntp-open-connection-function 'nntp-open-network-stream) - ;; Ok, this is evil, but when using telnet and stuff - ;; as the connection method, it's important that the - ;; QUIT command actually is sent out before we kill - ;; the process. - (sleep-for 1)))) - (nntp-kill-buffer (process-buffer process)) - (setq process (car (pop nntp-connection-alist)))) - (nnoo-close-server 'nntp))) - -(deffoo nntp-request-close () - (let (process) - (while (setq process (pop nntp-connection-list)) - (when (memq (process-status process) '(open run)) - (ignore-errors - (nntp-send-string process "QUIT") - (unless (eq nntp-open-connection-function 'nntp-open-network-stream) - ;; Ok, this is evil, but when using telnet and stuff - ;; as the connection method, it's important that the - ;; QUIT command actually is sent out before we kill - ;; the process. - (sleep-for 1)))) - (nntp-kill-buffer (process-buffer process))))) - -(deffoo nntp-request-list (&optional server) - "List active groups. If `nntp-list-options' is non-nil, the listing -output from the server will be restricted to the specified newsgroups. -If `nntp-options-subscribe' is non-nil, remove newsgroups that do not -match the regexp. If `nntp-options-not-subscribe' is non-nil, remove -newsgroups that match the regexp." - (nntp-possibly-change-group nil server) - (with-current-buffer nntp-server-buffer - (prog1 - (if (not nntp-list-options) - (nntp-send-command-and-decode "\r?\n\\.\r?\n" "LIST") - (let ((options (if (consp nntp-list-options) - nntp-list-options - (list nntp-list-options))) - (ret t)) - (erase-buffer) - (while options - (goto-char (point-max)) - (narrow-to-region (point) (point)) - (setq ret (and ret - (nntp-send-command-nodelete - "\r?\n\\.\r?\n" - (format "LIST ACTIVE %s" (car options)))) - options (cdr options)) - (nntp-decode-text)) - (widen) - ret)) - (when (and (stringp nntp-options-subscribe) - (not (string-equal "" nntp-options-subscribe))) - (goto-char (point-min)) - (keep-lines nntp-options-subscribe)) - (when (and (stringp nntp-options-not-subscribe) - (not (string-equal "" nntp-options-not-subscribe))) - (goto-char (point-min)) - (flush-lines nntp-options-subscribe))))) - -(deffoo nntp-request-list-newsgroups (&optional server) - (nntp-possibly-change-group nil server) - (nntp-send-command "\r?\n\\.\r?\n" "LIST NEWSGROUPS")) - -(deffoo nntp-request-newgroups (date &optional server) - (nntp-possibly-change-group nil server) - (save-excursion - (set-buffer nntp-server-buffer) - (let* ((time (date-to-time date)) - (ls (- (cadr time) (nth 8 (decode-time time))))) - (cond ((< ls 0) - (setcar time (1- (car time))) - (setcar (cdr time) (+ ls 65536))) - ((>= ls 65536) - (setcar time (1+ (car time))) - (setcar (cdr time) (- ls 65536))) - (t - (setcar (cdr time) ls))) - (prog1 - (nntp-send-command - "^\\.\r?\n" "NEWGROUPS" - (format-time-string "%y%m%d %H%M%S" time) - "GMT") - (nntp-decode-text))))) - -(deffoo nntp-request-post (&optional server) - (nntp-possibly-change-group nil server) - (when (nntp-send-command "^[23].*\r?\n" "POST") - (let ((response (save-current-buffer - (set-buffer nntp-server-buffer) - nntp-process-response)) - server-id) - (when (and response - (string-match "^[23].*\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)" - response)) - (setq server-id (match-string 1 response)) - (narrow-to-region (goto-char (point-min)) - (if (search-forward "\n\n" nil t) - (1- (point)) - (point-max))) - (unless (mail-fetch-field "Message-ID") - (goto-char (point-min)) - (insert "Message-ID: " server-id "\n")) - (widen)) - (run-hooks 'nntp-prepare-post-hook) - (nntp-send-buffer "^[23].*\n")))) - -(deffoo nntp-request-type (group article) - 'news) - -(deffoo nntp-asynchronous-p () - t) - -;;; Hooky functions. - -(defun nntp-send-mode-reader () - "Send the MODE READER command to the nntp server. -This function is supposed to be called from `nntp-server-opened-hook'. -It will make innd servers spawn an nnrpd process to allow actual article -reading." - (nntp-send-command "^.*\n" "MODE READER")) - -(defun nntp-send-authinfo (&optional send-if-force) - "Send the AUTHINFO to the nntp server. -It will look in the \"~/.authinfo\" file for matching entries. If -nothing suitable is found there, it will prompt for a user name -and a password. - -If SEND-IF-FORCE, only send authinfo to the server if the -.authinfo file has the FORCE token." - (let* ((list (gnus-parse-netrc nntp-authinfo-file)) - (alist (gnus-netrc-machine list nntp-address "nntp")) - (force (gnus-netrc-get alist "force")) - (user (or (gnus-netrc-get alist "login") nntp-authinfo-user)) - (passwd (gnus-netrc-get alist "password"))) - (when (or (not send-if-force) - force) - (unless user - (setq user (read-string (format "NNTP (%s) user name: " nntp-address)) - nntp-authinfo-user user)) - (unless (member user '(nil "")) - (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" user) - (when t ;???Should check if AUTHINFO succeeded - (nntp-send-command - "^2.*\r?\n" "AUTHINFO PASS" - (or passwd - nntp-authinfo-password - (setq nntp-authinfo-password - (mail-source-read-passwd - (format "NNTP (%s@%s) password: " - user nntp-address)))))))))) - -(defun nntp-send-nosy-authinfo () - "Send the AUTHINFO to the nntp server." - (let ((user (read-string (format "NNTP (%s) user name: " nntp-address)))) - (unless (member user '(nil "")) - (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" user) - (when t ;???Should check if AUTHINFO succeeded - (nntp-send-command "^2.*\r?\n" "AUTHINFO PASS" - (mail-source-read-passwd "NNTP (%s@%s) password: " - user nntp-address)))))) - -(defun nntp-send-authinfo-from-file () - "Send the AUTHINFO to the nntp server. - -The authinfo login name is taken from the user's login name and the -password contained in '~/.nntp-authinfo'." - (when (file-exists-p "~/.nntp-authinfo") - (with-temp-buffer - (insert-file-contents "~/.nntp-authinfo") - (goto-char (point-min)) - (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" (user-login-name)) - (nntp-send-command - "^2.*\r?\n" "AUTHINFO PASS" - (buffer-substring (point) (progn (end-of-line) (point))))))) - -;;; Internal functions. - -(defun nntp-handle-authinfo (process) - "Take care of an authinfo response from the server." - (let ((last nntp-last-command)) - (funcall nntp-authinfo-function) - ;; We have to re-send the function that was interrupted by - ;; the authinfo request. - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer)) - (nntp-send-string process last))) - -(defun nntp-make-process-buffer (buffer) - "Create a new, fresh buffer usable for nntp process connections." - (save-excursion - (set-buffer - (generate-new-buffer - (format " *server %s %s %s*" - nntp-address nntp-port-number - (gnus-buffer-exists-p buffer)))) - (set (make-local-variable 'after-change-functions) nil) - (set (make-local-variable 'nntp-process-wait-for) nil) - (set (make-local-variable 'nntp-process-callback) nil) - (set (make-local-variable 'nntp-process-to-buffer) nil) - (set (make-local-variable 'nntp-process-start-point) nil) - (set (make-local-variable 'nntp-process-decode) nil) - (current-buffer))) - -(defun nntp-open-connection (buffer) - "Open a connection to PORT on ADDRESS delivering output to BUFFER." - (run-hooks 'nntp-prepare-server-hook) - (let* ((pbuffer (nntp-make-process-buffer buffer)) - (timer - (and nntp-connection-timeout - (nnheader-run-at-time - nntp-connection-timeout nil - `(lambda () - (nntp-kill-buffer ,pbuffer))))) - (process - (condition-case () - (funcall nntp-open-connection-function pbuffer) - (error nil) - (quit - (message "Quit opening connection") - (nntp-kill-buffer pbuffer) - (signal 'quit nil) - nil)))) - (when timer - (nnheader-cancel-timer timer)) - (unless process - (nntp-kill-buffer pbuffer)) - (when (and (buffer-name pbuffer) - process) - (process-kill-without-query process) - (if (and (nntp-wait-for process "^2.*\n" buffer nil t) - (memq (process-status process) '(open run))) - (prog1 - (caar (push (list process buffer nil) nntp-connection-alist)) - (push process nntp-connection-list) - (save-excursion - (set-buffer pbuffer) - (nntp-read-server-type) - (erase-buffer) - (set-buffer nntp-server-buffer) - (let ((nnheader-callback-function nil)) - (run-hooks 'nntp-server-opened-hook) - (nntp-send-authinfo t)))) - (nntp-kill-buffer (process-buffer process)) - nil)))) - -(defun nntp-open-network-stream (buffer) - (open-network-stream-as-binary - "nntpd" buffer nntp-address nntp-port-number)) - -(defun nntp-open-ssl-stream (buffer) - (let ((proc (open-ssl-stream "nntpd" buffer nntp-address nntp-port-number))) - (save-excursion - (set-buffer buffer) - (nntp-wait-for-string "^\r*20[01]") - (beginning-of-line) - (delete-region (point-min) (point)) - proc))) - -(defun nntp-read-server-type () - "Find out what the name of the server we have connected to is." - ;; Wait for the status string to arrive. - (setq nntp-server-type (buffer-string)) - (let ((alist nntp-server-action-alist) - (case-fold-search t) - entry) - ;; Run server-specific commands. - (while alist - (setq entry (pop alist)) - (when (string-match (car entry) nntp-server-type) - (if (and (listp (cadr entry)) - (not (eq 'lambda (caadr entry)))) - (eval (cadr entry)) - (funcall (cadr entry))))))) - -(defun nntp-async-wait (process wait-for buffer decode callback) - (save-excursion - (set-buffer (process-buffer process)) - (unless nntp-inside-change-function - (erase-buffer)) - (setq nntp-process-wait-for wait-for - nntp-process-to-buffer buffer - nntp-process-decode decode - nntp-process-callback callback - nntp-process-start-point (point-max)) - (setq after-change-functions '(nntp-after-change-function)) - (if nntp-async-needs-kluge - (nntp-async-kluge process)))) - -(defun nntp-async-kluge (process) - ;; emacs 20.3 bug: process output with encoding 'binary - ;; doesn't trigger after-change-functions. - (unless nntp-async-timer - (setq nntp-async-timer - (nnheader-run-at-time 1 1 'nntp-async-timer-handler))) - (add-to-list 'nntp-async-process-list process)) - -(defun nntp-async-timer-handler () - (mapcar - (lambda (proc) - (if (memq (process-status proc) '(open run)) - (nntp-async-trigger proc) - (nntp-async-stop proc))) - nntp-async-process-list)) - -(defun nntp-async-stop (proc) - (setq nntp-async-process-list (delq proc nntp-async-process-list)) - (when (and nntp-async-timer (not nntp-async-process-list)) - (nnheader-cancel-timer nntp-async-timer) - (setq nntp-async-timer nil))) - -(defun nntp-after-change-function (beg end len) - (unwind-protect - ;; we only care about insertions at eob - (when (and (eq 0 len) (eq (point-max) end)) - (save-match-data - (let ((proc (get-buffer-process (current-buffer)))) - (when proc - (nntp-async-trigger proc))))) - ;; any throw from after-change-functions will leave it - ;; set to nil. so we reset it here, if necessary. - (when quit-flag - (setq after-change-functions '(nntp-after-change-function))))) - -(defun nntp-async-trigger (process) - (save-excursion - (set-buffer (process-buffer process)) - (when nntp-process-callback - ;; do we have an error message? - (goto-char nntp-process-start-point) - (if (memq (following-char) '(?4 ?5)) - ;; wants credentials? - (if (looking-at "480") - (nntp-handle-authinfo process) - ;; report error message. - (nntp-snarf-error-message) - (nntp-do-callback nil)) - - ;; got what we expect? - (goto-char (point-max)) - (when (re-search-backward - nntp-process-wait-for nntp-process-start-point t) - (let ((response (match-string 0))) - (save-current-buffer - (set-buffer nntp-server-buffer) - (setq nntp-process-response response))) - (nntp-async-stop process) - ;; convert it. - (when (gnus-buffer-exists-p nntp-process-to-buffer) - (let ((buf (current-buffer)) - (start nntp-process-start-point) - (decode nntp-process-decode)) - (save-excursion - (set-buffer nntp-process-to-buffer) - (goto-char (point-max)) - (save-restriction - (narrow-to-region (point) (point)) - (insert-buffer-substring buf start) - (when decode - (nntp-decode-text)))))) - ;; report it. - (goto-char (point-max)) - (nntp-do-callback - (buffer-name (get-buffer nntp-process-to-buffer)))))))) - -(defun nntp-do-callback (arg) - (let ((callback nntp-process-callback) - (nntp-inside-change-function t)) - (setq nntp-process-callback nil) - (funcall callback arg))) - -(defun nntp-snarf-error-message () - "Save the error message in the current buffer." - (let ((message (buffer-string))) - (while (string-match "[\r\n]+" message) - (setq message (replace-match " " t t message))) - (nnheader-report 'nntp message) - message)) - -(defun nntp-accept-process-output (process &optional timeout) - "Wait for output from PROCESS and message some dots." - (save-excursion - (set-buffer (or (nntp-find-connection-buffer nntp-server-buffer) - nntp-server-buffer)) - (let ((len (/ (point-max) 1024)) - message-log-max) - (unless (< len 10) - (setq nntp-have-messaged t) - (nnheader-message 7 "nntp read: %dk" len))) - (accept-process-output process (or timeout 1)))) - -(defun nntp-accept-response () - "Wait for output from the process that outputs to BUFFER." - (nntp-accept-process-output (nntp-find-connection nntp-server-buffer))) - -(defun nntp-possibly-change-group (group server &optional connectionless) - (let ((nnheader-callback-function nil)) - (when server - (or (nntp-server-opened server) - (nntp-open-server server nil connectionless))) - - (unless connectionless - (or (nntp-find-connection nntp-server-buffer) - (nntp-open-connection nntp-server-buffer)))) - - (when group - (let ((entry (nntp-find-connection-entry nntp-server-buffer))) - (when (not (equal group (caddr entry))) - (save-excursion - (set-buffer (process-buffer (car entry))) - (erase-buffer) - (nntp-send-command "^[245].*\n" "GROUP" group) - (setcar (cddr entry) group) - (erase-buffer)))))) - -(defun nntp-decode-text (&optional cr-only) - "Decode the text in the current buffer." - (goto-char (point-min)) - (while (search-forward "\r" nil t) - (delete-char -1)) - (unless cr-only - ;; Remove trailing ".\n" end-of-transfer marker. - (goto-char (point-max)) - (forward-line -1) - (when (looking-at ".\n") - (delete-char 2)) - ;; Delete status line. - (goto-char (point-min)) - (while (looking-at "[1-5][0-9][0-9] .*\n") - ;; For some unknown reason, there is more than one status line. - (delete-region (point) (progn (forward-line 1) (point)))) - ;; Remove "." -> ".." encoding. - (while (search-forward "\n.." nil t) - (delete-char -1)))) - -(defun nntp-encode-text () - "Encode the text in the current buffer." - (save-excursion - ;; Replace "." at beginning of line with "..". - (goto-char (point-min)) - (while (re-search-forward "^\\." nil t) - (insert ".")) - (goto-char (point-max)) - ;; Insert newline at the end of the buffer. - (unless (bolp) - (insert "\n")) - ;; Insert `.' at end of buffer (end of text mark). - (goto-char (point-max)) - (insert ".\n") - (goto-char (point-min)) - (while (not (eobp)) - (end-of-line) - (delete-char 1) - (insert nntp-end-of-line)))) - -(defun nntp-retrieve-headers-with-xover (articles &optional fetch-old) - (set-buffer nntp-server-buffer) - (erase-buffer) - (cond - - ;; This server does not talk NOV. - ((not nntp-server-xover) - nil) - - ;; We don't care about gaps. - ((or (not nntp-nov-gap) - fetch-old) - (nntp-send-xover-command - (if fetch-old - (if (numberp fetch-old) - (max 1 (- (car articles) fetch-old)) - 1) - (car articles)) - (car (last articles)) 'wait) - - (goto-char (point-min)) - (when (looking-at "[1-5][0-9][0-9] .*\n") - (delete-region (point) (progn (forward-line 1) (point)))) - (while (search-forward "\r" nil t) - (replace-match "" t t)) - (goto-char (point-max)) - (forward-line -1) - (when (looking-at "\\.") - (delete-region (point) (progn (forward-line 1) (point))))) - - ;; We do it the hard way. For each gap, an XOVER command is sent - ;; to the server. We do not wait for a reply from the server, we - ;; just send them off as fast as we can. That means that we have - ;; to count the number of responses we get back to find out when we - ;; have gotten all we asked for. - ((numberp nntp-nov-gap) - (let ((count 0) - (received 0) - last-point - in-process-buffer-p - (buf nntp-server-buffer) - (process-buffer (nntp-find-connection-buffer nntp-server-buffer)) - first) - ;; We have to check `nntp-server-xover'. If it gets set to nil, - ;; that means that the server does not understand XOVER, but we - ;; won't know that until we try. - (while (and nntp-server-xover articles) - (setq first (car articles)) - ;; Search forward until we find a gap, or until we run out of - ;; articles. - (while (and (cdr articles) - (< (- (nth 1 articles) (car articles)) nntp-nov-gap)) - (setq articles (cdr articles))) - - (setq in-process-buffer-p (stringp nntp-server-xover)) - (nntp-send-xover-command first (car articles)) - (setq articles (cdr articles)) - - (when (and nntp-server-xover in-process-buffer-p) - ;; Don't count tried request. - (setq count (1+ count)) - - ;; Every 400 requests we have to read the stream in - ;; order to avoid deadlocks. - (when (or (null articles) ;All requests have been sent. - (zerop (% count nntp-maximum-request))) - - (nntp-accept-response) - ;; On some Emacs versions the preceding function has a - ;; tendency to change the buffer. Perhaps. It's quite - ;; difficult to reproduce, because it only seems to happen - ;; once in a blue moon. - (set-buffer process-buffer) - (while (progn - (goto-char (or last-point (point-min))) - ;; Count replies. - (while (re-search-forward "^[0-9][0-9][0-9] .*\n" nil t) - (incf received)) - (setq last-point (point)) - (< received count)) - (nntp-accept-response) - (set-buffer process-buffer)) - (set-buffer buf)))) - - (when nntp-server-xover - (when in-process-buffer-p - (set-buffer process-buffer) - ;; Wait for the reply from the final command. - (goto-char (point-max)) - (while (not (re-search-backward "^[0-9][0-9][0-9] " nil t)) - (nntp-accept-response) - (set-buffer process-buffer) - (goto-char (point-max))) - (when (looking-at "^[23]") - (while (progn - (goto-char (point-max)) - (forward-line -1) - (not (looking-at "^\\.\r?\n"))) - (nntp-accept-response) - (set-buffer process-buffer))) - (set-buffer buf) - (goto-char (point-max)) - (insert-buffer-substring process-buffer) - (set-buffer process-buffer) - (erase-buffer) - (set-buffer buf)) - - ;; We remove any "." lines and status lines. - (goto-char (point-min)) - (while (search-forward "\r" nil t) - (delete-char -1)) - (goto-char (point-min)) - (delete-matching-lines "^\\.$\\|^[1-5][0-9][0-9] ") - t)))) - - nntp-server-xover) - -(defun nntp-send-xover-command (beg end &optional wait-for-reply) - "Send the XOVER command to the server." - (let ((range (format "%d-%d" beg end)) - (nntp-inhibit-erase t)) - (if (stringp nntp-server-xover) - ;; If `nntp-server-xover' is a string, then we just send this - ;; command. - (if wait-for-reply - (nntp-send-command-nodelete - "\r?\n\\.\r?\n" nntp-server-xover range) - ;; We do not wait for the reply. - (nntp-send-command-nodelete nil nntp-server-xover range)) - (let ((commands nntp-xover-commands)) - ;; `nntp-xover-commands' is a list of possible XOVER commands. - ;; We try them all until we get at positive response. - (while (and commands (eq nntp-server-xover 'try)) - (nntp-send-command-nodelete "\r?\n\\.\r?\n" (car commands) range) - (save-excursion - (set-buffer nntp-server-buffer) - (goto-char (point-min)) - (and (looking-at "[23]") ; No error message. - ;; We also have to look at the lines. Some buggy - ;; servers give back simple lines with just the - ;; article number. How... helpful. - (progn - (forward-line 1) - (looking-at "[0-9]+\t...")) ; More text after number. - (setq nntp-server-xover (car commands)))) - (setq commands (cdr commands))) - ;; If none of the commands worked, we disable XOVER. - (when (eq nntp-server-xover 'try) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (setq nntp-server-xover nil))) - nntp-server-xover)))) - -(defun nntp-find-group-and-number () - (save-excursion - (save-restriction - (set-buffer nntp-server-buffer) - (narrow-to-region (goto-char (point-min)) - (or (search-forward "\n\n" nil t) (point-max))) - (goto-char (point-min)) - ;; We first find the number by looking at the status line. - (let ((number (and (looking-at "2[0-9][0-9] +\\([0-9]+\\) ") - (string-to-int - (buffer-substring (match-beginning 1) - (match-end 1))))) - group newsgroups xref) - (and number (zerop number) (setq number nil)) - ;; Then we find the group name. - (setq group - (cond - ;; If there is only one group in the Newsgroups header, - ;; then it seems quite likely that this article comes - ;; from that group, I'd say. - ((and (setq newsgroups (mail-fetch-field "newsgroups")) - (not (string-match "," newsgroups))) - newsgroups) - ;; If there is more than one group in the Newsgroups - ;; header, then the Xref header should be filled out. - ;; We hazard a guess that the group that has this - ;; article number in the Xref header is the one we are - ;; looking for. This might very well be wrong if this - ;; article happens to have the same number in several - ;; groups, but that's life. - ((and (setq xref (mail-fetch-field "xref")) - number - (string-match (format "\\([^ :]+\\):%d" number) xref)) - (substring xref (match-beginning 1) (match-end 1))) - (t ""))) - (when (string-match "\r" group) - (setq group (substring group 0 (match-beginning 0)))) - (cons group number))))) - -(defun nntp-wait-for-string (regexp) - "Wait until string arrives in the buffer." - (let ((buf (current-buffer))) - (goto-char (point-min)) - (while (not (re-search-forward regexp nil t)) - (accept-process-output (nntp-find-connection nntp-server-buffer)) - (set-buffer buf) - (goto-char (point-min))))) - - -;; ========================================================================== -;; Obsolete nntp-open-* connection methods -- drv -;; ========================================================================== - -(defvoo nntp-open-telnet-envuser nil - "*If non-nil, telnet session (client and server both) will support the ENVIRON option and not prompt for login name.") - -(defvoo nntp-telnet-shell-prompt "bash\\|\$ *\r?$\\|> *\r?" - "*Regular expression to match the shell prompt on the remote machine.") - -(defvoo nntp-rlogin-program "rsh" - "*Program used to log in on remote machines. -The default is \"rsh\", but \"ssh\" is a popular alternative.") - -(defvoo nntp-rlogin-parameters '("telnet" "-8" "${NNTPSERVER:=news}" "nntp") - "*Parameters to `nntp-open-rlogin'. -That function may be used as `nntp-open-connection-function'. In that -case, this list will be used as the parameter list given to rsh.") - -(defvoo nntp-rlogin-user-name nil - "*User name on remote system when using the rlogin connect method.") - -(defvoo nntp-telnet-parameters - '("exec" "telnet" "-8" "${NNTPSERVER:=news}" "nntp") - "*Parameters to `nntp-open-telnet'. -That function may be used as `nntp-open-connection-function'. In that -case, this list will be executed as a command after logging in -via telnet.") - -(defvoo nntp-telnet-user-name nil - "User name to log in via telnet with.") - -(defvoo nntp-telnet-passwd nil - "Password to use to log in via telnet with.") - -(defun nntp-open-telnet (buffer) - (save-excursion - (set-buffer buffer) - (erase-buffer) - (let ((proc (as-binary-process - (apply - 'start-process - "nntpd" buffer nntp-telnet-command nntp-telnet-switches))) - (case-fold-search t)) - (when (memq (process-status proc) '(open run)) - (nntp-wait-for-string "^r?telnet") - (process-send-string proc "set escape \^X\n") - (cond - ((and nntp-open-telnet-envuser nntp-telnet-user-name) - (process-send-string proc (concat "open " "-l" nntp-telnet-user-name - nntp-address "\n"))) - (t - (process-send-string proc (concat "open " nntp-address "\n")))) - (cond - ((not nntp-open-telnet-envuser) - (nntp-wait-for-string "^\r*.?login:") - (process-send-string - proc (concat - (or nntp-telnet-user-name - (setq nntp-telnet-user-name (read-string "login: "))) - "\n")))) - (nntp-wait-for-string "^\r*.?password:") - (process-send-string - proc (concat - (or nntp-telnet-passwd - (setq nntp-telnet-passwd - (mail-source-read-passwd "Password: "))) - "\n")) - (nntp-wait-for-string nntp-telnet-shell-prompt) - (process-send-string - proc (concat (mapconcat 'identity nntp-telnet-parameters " ") "\n")) - (nntp-wait-for-string "^\r*20[01]") - (beginning-of-line) - (delete-region (point-min) (point)) - (process-send-string proc "\^]") - (nntp-wait-for-string "^r?telnet") - (process-send-string proc "mode character\n") - (accept-process-output proc 1) - (sit-for 1) - (goto-char (point-min)) - (forward-line 1) - (delete-region (point) (point-max))) - proc))) - -(defun nntp-open-rlogin (buffer) - "Open a connection to SERVER using rsh." - (let ((proc (if nntp-rlogin-user-name - (as-binary-process - (apply 'start-process - "nntpd" buffer nntp-rlogin-program - nntp-address "-l" nntp-rlogin-user-name - nntp-rlogin-parameters)) - (as-binary-process - (apply 'start-process - "nntpd" buffer nntp-rlogin-program nntp-address - nntp-rlogin-parameters))))) - (save-excursion - (set-buffer buffer) - (nntp-wait-for-string "^\r*20[01]") - (beginning-of-line) - (delete-region (point-min) (point)) - proc))) - - -;; ========================================================================== -;; Replacements for the nntp-open-* functions -- drv -;; ========================================================================== - -(defun nntp-open-telnet-stream (buffer) - "Open a nntp connection by telnet'ing the news server. - -Please refer to the following variables to customize the connection: -- `nntp-pre-command', -- `nntp-telnet-command', -- `nntp-telnet-switches', -- `nntp-address', -- `nntp-port-number', -- `nntp-end-of-line'." - (let ((command `(,nntp-telnet-command - ,@nntp-telnet-switches - ,nntp-address ,nntp-port-number)) - proc) - (and nntp-pre-command - (push nntp-pre-command command)) - (setq proc (apply 'start-process "nntpd" buffer command)) - (save-excursion - (set-buffer buffer) - (nntp-wait-for-string "^\r*20[01]") - (beginning-of-line) - (delete-region (point-min) (point)) - proc))) - -(defun nntp-open-via-rlogin-and-telnet (buffer) - "Open a connection to an nntp server through an intermediate host. -First rlogin to the remote host, and then telnet the real news server -from there. - -Please refer to the following variables to customize the connection: -- `nntp-pre-command', -- `nntp-via-rlogin-command', -- `nntp-via-user-name', -- `nntp-via-address', -- `nntp-telnet-command', -- `nntp-telnet-switches', -- `nntp-address', -- `nntp-port-number', -- `nntp-end-of-line'." - (let ((command `(,nntp-via-address - ,nntp-telnet-command - ,@nntp-telnet-switches - ,nntp-address ,nntp-port-number)) - proc) - (and nntp-via-user-name - (setq command `("-l" ,nntp-via-user-name ,@command))) - (push nntp-via-rlogin-command command) - (and nntp-pre-command - (push nntp-pre-command command)) - (setq proc (apply 'start-process "nntpd" buffer command)) - (save-excursion - (set-buffer buffer) - (nntp-wait-for-string "^\r*20[01]") - (beginning-of-line) - (delete-region (point-min) (point)) - proc))) - -(defun nntp-open-via-telnet-and-telnet (buffer) - "Open a connection to an nntp server through an intermediate host. -First telnet the remote host, and then telnet the real news server -from there. - -Please refer to the following variables to customize the connection: -- `nntp-pre-command', -- `nntp-via-telnet-command', -- `nntp-via-telnet-switches', -- `nntp-via-address', -- `nntp-via-envuser', -- `nntp-via-user-name', -- `nntp-via-user-password', -- `nntp-via-shell-prompt', -- `nntp-telnet-command', -- `nntp-telnet-switches', -- `nntp-address', -- `nntp-port-number', -- `nntp-end-of-line'." - (save-excursion - (set-buffer buffer) - (erase-buffer) - (let ((command `(,nntp-via-telnet-command ,@nntp-via-telnet-switches)) - (case-fold-search t) - proc) - (and nntp-pre-command (push nntp-pre-command command)) - (setq proc (apply 'start-process "nntpd" buffer command)) - (when (memq (process-status proc) '(open run)) - (nntp-wait-for-string "^r?telnet") - (process-send-string proc "set escape \^X\n") - (cond - ((and nntp-via-envuser nntp-via-user-name) - (process-send-string proc (concat "open " "-l" nntp-via-user-name - nntp-via-address "\n"))) - (t - (process-send-string proc (concat "open " nntp-via-address - "\n")))) - (when (not nntp-via-envuser) - (nntp-wait-for-string "^\r*.?login:") - (process-send-string proc - (concat - (or nntp-via-user-name - (setq nntp-via-user-name - (read-string "login: "))) - "\n"))) - (nntp-wait-for-string "^\r*.?password:") - (process-send-string proc - (concat - (or nntp-via-user-password - (setq nntp-via-user-password - (mail-source-read-passwd - "Password: "))) - "\n")) - (nntp-wait-for-string nntp-via-shell-prompt) - (let ((real-telnet-command `("exec" - ,nntp-telnet-command - ,@nntp-telnet-switches - ,nntp-address - ,nntp-port-number))) - (process-send-string proc - (concat (mapconcat 'identity - real-telnet-command " ") - "\n"))) - (nntp-wait-for-string "^\r*20[01]") - (beginning-of-line) - (delete-region (point-min) (point)) - (process-send-string proc "\^]") - (nntp-wait-for-string "^r?telnet") - (process-send-string proc "mode character\n") - (accept-process-output proc 1) - (sit-for 1) - (goto-char (point-min)) - (forward-line 1) - (delete-region (point) (point-max))) - proc))) - -(provide 'nntp) - -;;; nntp.el ends here