X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnntp.el;h=b25f5f57051b1bbb98de2a0e16611a130c19ad5c;hb=7709e53c759e9432e8b52e5280062d0b03b4dab2;hp=a12821901270838d80bb07a289df73b0de73860e;hpb=426db3fde8078af0efa339b9547118256201d487;p=gnus diff --git a/lisp/nntp.el b/lisp/nntp.el index a12821901..b25f5f570 100644 --- a/lisp/nntp.el +++ b/lisp/nntp.el @@ -1,7 +1,7 @@ ;;; nntp.el --- nntp access for Gnus + ;; Copyright (C) 1987, 1988, 1989, 1990, 1992, 1993, 1994, 1995, 1996, -;; 1997, 1998, 2000 -;; Free Software Foundation, Inc. +;; 1997, 1998, 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -9,18 +9,18 @@ ;; 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. +;; 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. +;; 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. +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;; Commentary: @@ -65,61 +65,91 @@ 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. +It will be called with the buffer to output in as argument. -Two pre-made functions are `nntp-open-network-stream', which is the -default, and simply connects to some port or other on the remote -system (see nntp-port-number). The other are `nntp-open-rlogin', -which does an rlogin on the remote system, and then does a telnet to -the NNTP server available there (see nntp-rlogin-parameters) and -`nntp-open-telnet' which telnets to a remote system, logs in and does -the same.") +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. -(defvoo nntp-rlogin-program "rsh" - "*Program used to log in on remote machines. -The default is \"rsh\", but \"ssh\" is a popular alternative.") +Direct connections: +- `nntp-open-network-stream' (the default), +- `nntp-open-ssl-stream', +- `nntp-open-tls-stream', +- `nntp-open-telnet-stream'. -(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.") +Indirect connections: +- `nntp-open-via-rlogin-and-telnet', +- `nntp-open-via-rlogin-and-netcat', +- `nntp-open-via-telnet-and-telnet'.") -(defvoo nntp-rlogin-user-name nil - "*User name on remote system when using the rlogin connect method.") +(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-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-command "telnet" + "*Telnet command used to connect to the nntp server. +This command is used by the methods `nntp-open-telnet-stream', +`nntp-open-via-rlogin-and-telnet' and `nntp-open-via-telnet-and-telnet'.") -(defvoo nntp-telnet-user-name nil - "User name to log in via telnet with.") +(defvoo nntp-telnet-switches '("-8") + "*Switches given to the telnet command `nntp-telnet-command'.") -(defvoo nntp-telnet-passwd nil - "Password to use to log in via telnet with.") +(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 telnet connection method (nntp-open-via-*-and-telnet).") -(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-via-rlogin-command "rsh" + "*Rlogin command used to connect to an intermediate host. +This command is used by the methods `nntp-open-via-rlogin-and-telnet' +and `nntp-open-via-rlogin-and-netcat'. The default is \"rsh\", but \"ssh\" +is a popular alternative.") -(defvoo nntp-telnet-shell-prompt "bash\\|\$ *\r?$\\|> *\r?" - "*Regular expression to match the shell prompt on the remote machine.") +(defvoo nntp-via-rlogin-command-switches nil + "*Switches given to the rlogin command `nntp-via-rlogin-command'. +If you use \"ssh\" for `nntp-via-rlogin-command', you may set this to +\(\"-C\") in order to compress all data connections, otherwise set this +to \(\"-t\" \"-e\" \"none\") or (\"-C\" \"-t\" \"-e\" \"none\") if the telnet +command requires a pseudo-tty allocation on an intermediate host.") -(defvoo nntp-telnet-command "telnet" - "Command used to start telnet.") +(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-telnet-switches '("-8") - "Switches given to the telnet command.") +(defvoo nntp-via-telnet-switches '("-8") + "*Switches given to the telnet command `nntp-via-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 rlogin or telnet to communicate with the server.") +(defvoo nntp-via-netcat-command "nc" + "*Netcat command used to connect to the nntp server. +This command is used by the `nntp-open-via-rlogin-and-netcat' method.") + +(defvoo nntp-via-netcat-switches nil + "*Switches given to the netcat command `nntp-via-netcat-command'.") + +(defvoo nntp-via-user-name nil + "*User name to log in on an intermediate host with. +This variable is used by the various nntp-open-via-* methods.") + +(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 various nntp-open-via-* 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 + "*The number of articles which indicates a large newsgroup. +If the number of articles is greater than the value, verbose messages will be shown to indicate the current status.") (defvoo nntp-maximum-request 400 @@ -159,6 +189,21 @@ server there that you can connect to. See also (defvoo nntp-coding-system-for-write 'binary "*Coding system to write to NNTP.") +;; Marks +(defvoo nntp-marks-is-evil nil + "*If non-nil, GNus will never generate and use marks file for nntp groups. +See `nnml-marks-is-evil' for more information.") + +(defvoo nntp-marks-file-name ".marks") +(defvoo nntp-marks nil) +(defvar nntp-marks-modtime (gnus-make-hashtable)) + +(defcustom nntp-marks-directory + (nnheader-concat gnus-directory "marks/") + "*The directory where marks for nntp groups will be stored." + :group 'gnus + :type 'directory) + (defcustom nntp-authinfo-file "~/.authinfo" ".netrc-like file that holds nntp authinfo passwords." :type @@ -180,7 +225,12 @@ server there that you can connect to. See also (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.") +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 +to insert Cancel-Lock headers.") ;;; Internal variables. @@ -222,9 +272,12 @@ 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")) +(defvar nntp-ssl-program + "openssl s_client -quiet -ssl3 -connect %s:%p" +"A string containing commands for SSL connections. +Within a string, %s is replaced with the server address and %p with +port number on server. The program should accept IMAP commands on +stdin and return responses to stdout.") @@ -239,7 +292,9 @@ noticing asynchronous data.") nntp-last-command string) (when nntp-record-commands (nntp-record-command string)) - (process-send-string process (concat string nntp-end-of-line))) + (process-send-string process (concat string nntp-end-of-line)) + (or (memq (process-status process) '(open run)) + (nntp-report "Server closed connection"))) (defun nntp-record-command (string) "Record the command STRING." @@ -251,6 +306,27 @@ noticing asynchronous data.") "." (format "%03d" (/ (nth 2 time) 1000)) " " nntp-address " " string "\n")))) +(defun nntp-report (&rest args) + "Report an error from the nntp backend. The first string in ARGS +can be a format string. For some commands, the failed command may be +retried once before actually displaying the error report." + + (when nntp-record-commands + (nntp-record-command "*** CALLED nntp-report ***")) + + (nnheader-report 'nntp args) + + (apply 'error args)) + +(defun nntp-report-1 (&rest args) + "Throws out to nntp-with-open-group-error so that the connection may +be restored and the command retried." + + (when nntp-record-commands + (nntp-record-command "*** CONNECTION LOST ***")) + + (throw 'nntp-with-open-group-error t)) + (defsubst nntp-wait-for (process wait-for buffer &optional decode discard) "Wait for WAIT-FOR to arrive from PROCESS." (save-excursion @@ -261,6 +337,8 @@ noticing asynchronous data.") (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 @@ -270,27 +348,31 @@ noticing asynchronous data.") (nntp-snarf-error-message) nil)) ((not (memq (process-status process) '(open run))) - (nnheader-report 'nntp "Server closed connection")) + (nntp-report "Server closed connection")) (t (goto-char (point-max)) - (let ((limit (point-min))) + (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)))) + (goto-char (point-max))) + (setq response (match-string 0)) + (with-current-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)) + (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)))) + (nnheader-message 5 "")))) + t)) (unless discard (erase-buffer))))) @@ -299,12 +381,17 @@ noticing asynchronous data.") (kill-buffer buffer) (nnheader-init-server-buffer))) +(defun nntp-erase-buffer (buffer) + "Erase contents of BUFFER." + (with-current-buffer buffer + (erase-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 (setq entry (pop alist)) + (while (and alist (setq entry (pop alist))) (when (eq buffer (cadr entry)) (setq process (car entry) alist nil))) @@ -330,74 +417,127 @@ noticing asynchronous data.") "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))))) + (if process + (progn + (unless (or nntp-inhibit-erase nnheader-callback-function) + (nntp-erase-buffer (process-buffer process))) + (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))) + (nnheader-report 'nntp "Couldn't open connection to %s" address)))) (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))) - (nntp-retrieve-data - (mapconcat 'identity strings " ") - nntp-address nntp-port-number nntp-server-buffer - wait-for nnheader-callback-function)) + (nntp-erase-buffer nntp-server-buffer)) + (let* ((command (mapconcat 'identity strings " ")) + (process (nntp-find-connection nntp-server-buffer)) + (buffer (and process (process-buffer process))) + (pos (and buffer (with-current-buffer buffer (point))))) + (if process + (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. + ;; We don't have echos if nntp-open-connection-function + ;; is `nntp-open-network-stream', so we skip this in that case. + (unless (or wait-for + (equal nntp-open-connection-function + 'nntp-open-network-stream)) + (nntp-accept-response) + (save-excursion + (set-buffer buffer) + (goto-char pos) + (if (looking-at (regexp-quote command)) + (delete-region pos (progn (forward-line 1) + (point-at-bol)))) + ))) + (nnheader-report 'nntp "Couldn't open connection to %s." + nntp-address)))) (defun nntp-send-command-nodelete (wait-for &rest strings) "Send STRINGS to server and wait until WAIT-FOR returns." - (nntp-retrieve-data - (mapconcat 'identity strings " ") - nntp-address nntp-port-number nntp-server-buffer - wait-for nnheader-callback-function)) + (let* ((command (mapconcat 'identity strings " ")) + (process (nntp-find-connection nntp-server-buffer)) + (buffer (and process (process-buffer process))) + (pos (and buffer (with-current-buffer buffer (point))))) + (if process + (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) + (point-at-bol))))))) + (nnheader-report 'nntp "Couldn't open connection to %s." + nntp-address)))) (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))) - (nntp-retrieve-data - (mapconcat 'identity strings " ") - nntp-address nntp-port-number nntp-server-buffer - wait-for nnheader-callback-function t)) + (nntp-erase-buffer nntp-server-buffer)) + (let* ((command (mapconcat 'identity strings " ")) + (process (nntp-find-connection nntp-server-buffer)) + (buffer (and process (process-buffer process))) + (pos (and buffer (with-current-buffer buffer (point))))) + (if process + (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) (point-at-bol)))) + ))) + (nnheader-report 'nntp "Couldn't open connection to %s." + nntp-address)))) + (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-erase-buffer + (nntp-find-connection-buffer nntp-server-buffer))) (nntp-encode-text) - (process-send-region (nntp-find-connection nntp-server-buffer) - (point-min) (point-max)) + (mm-with-unibyte-current-buffer + ;; Some encoded unicode text contains character 0x80-0x9f e.g. Euro. + (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)) @@ -426,208 +566,287 @@ noticing asynchronous data.") (t nil))) +(eval-when-compile + (defvar nntp-with-open-group-internal nil) + (defvar nntp-report-n nil)) + +(defmacro nntp-with-open-group (group server &optional connectionless &rest forms) + "Protect against servers that don't like clients that keep idle connections opens. +The problem being that these servers may either close a connection or +simply ignore any further requests on a connection. Closed +connections are not detected until accept-process-output has updated +the process-status. Dropped connections are not detected until the +connection timeouts (which may be several minutes) or +nntp-connection-timeout has expired. When these occur +nntp-with-open-group, opens a new connection then re-issues the NNTP +command whose response triggered the error." + (when (and (listp connectionless) + (not (eq connectionless nil))) + (setq forms (cons connectionless forms) + connectionless nil)) + `(letf ((nntp-report-n (symbol-function 'nntp-report)) + ((symbol-function 'nntp-report) (symbol-function 'nntp-report-1)) + (nntp-with-open-group-internal nil)) + (while (catch 'nntp-with-open-group-error + ;; Open the connection to the server + ;; NOTE: Existing connections are NOT tested. + (nntp-possibly-change-group ,group ,server ,connectionless) + + (let ((timer + (and nntp-connection-timeout + (run-at-time + nntp-connection-timeout nil + '(lambda () + (let ((process (nntp-find-connection + nntp-server-buffer)) + (buffer (and process + (process-buffer process)))) + ;; When I an able to identify the + ;; connection to the server AND I've + ;; received NO reponse for + ;; nntp-connection-timeout seconds. + (when (and buffer (eq 0 (buffer-size buffer))) + ;; Close the connection. Take no + ;; other action as the accept input + ;; code will handle the closed + ;; connection. + (nntp-kill-buffer buffer)))))))) + (unwind-protect + (setq nntp-with-open-group-internal + (condition-case nil + (progn ,@forms) + (quit + (nntp-close-server) + (signal 'quit nil)))) + (when timer + (nnheader-cancel-timer timer))) + nil)) + (setf (symbol-function 'nntp-report) nntp-report-n)) + nntp-with-open-group-internal)) + (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)))) + (nntp-with-open-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)) + (articles 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) - (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 (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. - (set-buffer buf) - (goto-char (point-max)) - (re-search-backward "^[0-9]" nil t) - (when (looking-at "^[23]") - (while (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. - (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))))) + (nntp-with-open-group + nil server + (when (nntp-find-connection-buffer nntp-server-buffer) + (catch 'done + (save-excursion + ;; Erase nntp-server-buffer before nntp-inhibit-erase. + (nntp-erase-buffer nntp-server-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) + (groups groups) + (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 + ;; Timeout may have killed the buffer. + (unless (gnus-buffer-live-p buf) + (nnheader-report 'nntp "Connection to %s is closed." server) + (throw 'done nil)) + ;; 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)))) + (nntp-with-open-group + group server + (save-excursion + (let ((number (length articles)) + (articles 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) @@ -642,47 +861,53 @@ noticing asynchronous data.") (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)) + (nntp-with-open-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)) + (nntp-with-open-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)))) + (nntp-with-open-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 group)) + (nntp-find-group-and-number group))))) (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)))) + (nntp-with-open-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 group) + (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))) + (nntp-with-open-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)))) + (nntp-with-open-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) @@ -740,27 +965,58 @@ noticing asynchronous data.") (nntp-kill-buffer (process-buffer process))))) (deffoo nntp-request-list (&optional server) - (nntp-possibly-change-group nil server) - (nntp-send-command-and-decode "\r?\n\\.\r?\n" "LIST")) + (nntp-with-open-group + nil server + (nntp-send-command-and-decode "\r?\n\\.\r?\n" "LIST"))) (deffoo nntp-request-list-newsgroups (&optional server) - (nntp-possibly-change-group nil server) - (nntp-send-command "\r?\n\\.\r?\n" "LIST NEWSGROUPS")) + (nntp-with-open-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) - (prog1 - (nntp-send-command - "^\\.\r?\n" "NEWGROUPS" - (format-time-string "%y%m%d %H%M%S" (date-to-time date))) - (nntp-decode-text)))) + (nntp-with-open-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") - (nntp-send-buffer "^[23].*\n"))) + (nntp-with-open-group + nil server + (when (nntp-send-command "^[23].*\r?\n" "POST") + (let ((response (with-current-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) @@ -768,6 +1024,54 @@ noticing asynchronous data.") (deffoo nntp-asynchronous-p () t) +(deffoo nntp-request-set-mark (group actions &optional server) + (unless nntp-marks-is-evil + (nntp-possibly-create-directory group server) + (nntp-open-marks group server) + (dolist (action actions) + (let ((range (nth 0 action)) + (what (nth 1 action)) + (marks (nth 2 action))) + (assert (or (eq what 'add) (eq what 'del)) nil + "Unknown request-set-mark action: %s" what) + (dolist (mark marks) + (setq nntp-marks (gnus-update-alist-soft + mark + (funcall (if (eq what 'add) 'gnus-range-add + 'gnus-remove-from-range) + (cdr (assoc mark nntp-marks)) range) + nntp-marks))))) + (nntp-save-marks group server)) + nil) + +(deffoo nntp-request-update-info (group info &optional server) + (unless nntp-marks-is-evil + (nntp-possibly-create-directory group server)) + (when (and (not nntp-marks-is-evil) (nntp-marks-changed-p group server)) + (nnheader-message 8 "Updating marks for %s..." group) + (nntp-open-marks group server) + ;; Update info using `nntp-marks'. + (mapc (lambda (pred) + (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists) + (gnus-info-set-marks + info + (gnus-update-alist-soft + (cdr pred) + (cdr (assq (cdr pred) nntp-marks)) + (gnus-info-marks info)) + t))) + gnus-article-mark-lists) + (let ((seen (cdr (assq 'read nntp-marks)))) + (gnus-info-set-read info + (if (and (integerp (car seen)) + (null (cdr seen))) + (list (cons (car seen) (car seen))) + seen))) + (nnheader-message 8 "Updating marks for %s...done" group)) + info) + + + ;;; Hooky functions. (defun nntp-send-mode-reader () @@ -803,9 +1107,8 @@ If SEND-IF-FORCE, only send authinfo to the server if the (or passwd nntp-authinfo-password (setq nntp-authinfo-password - (mail-source-read-passwd - (format "NNTP (%s@%s) password: " - user nntp-address)))))))))) + (read-passwd (format "NNTP (%s@%s) password: " + user nntp-address)))))))))) (defun nntp-send-nosy-authinfo () "Send the AUTHINFO to the nntp server." @@ -814,8 +1117,8 @@ If SEND-IF-FORCE, only send authinfo to the server if the (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)))))) + (read-passwd (format "NNTP (%s@%s) password: " + user nntp-address))))))) (defun nntp-send-authinfo-from-file () "Send the AUTHINFO to the nntp server. @@ -829,7 +1132,7 @@ password contained in '~/.nntp-authinfo'." (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))))))) + (buffer-substring (point) (point-at-eol)))))) ;;; Internal functions. @@ -839,9 +1142,7 @@ password contained in '~/.nntp-authinfo'." (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-erase-buffer nntp-server-buffer) (nntp-send-string process last))) (defun nntp-make-process-buffer (buffer) @@ -867,27 +1168,30 @@ password contained in '~/.nntp-authinfo'." (let* ((pbuffer (nntp-make-process-buffer buffer)) (timer (and nntp-connection-timeout - (nnheader-run-at-time + (run-at-