X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fnntp.el;h=6c4b226b28778e70611e49fb30c21cb2d5b39165;hp=15d7a7d8121e35ee1a7462c1d0eeb8474ad29ded;hb=06e3d74faa6b1196f0a7b877acc1bb6b6c1563a8;hpb=446a2833bc53b203097c3ca056270c3b3cf7e9b2 diff --git a/lisp/nntp.el b/lisp/nntp.el index 15d7a7d81..1bf2ce1e3 100644 --- a/lisp/nntp.el +++ b/lisp/nntp.el @@ -1,17 +1,18 @@ ;;; 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. + +;; Copyright (C) 1987, 1988, 1989, 1990, 1992, 1993, +;; 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, +;; 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. +;; the Free Software Foundation, either version 3 of the License, 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 @@ -19,21 +20,32 @@ ;; 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. If not, see . ;;; Commentary: ;;; Code: +;; For Emacs < 22.2. +(eval-and-compile + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + (require 'nnheader) (require 'nnoo) (require 'gnus-util) +(require 'gnus) +(require 'gnus-group) ;; gnus-group-name-charset (nnoo-declare nntp) (eval-when-compile (require 'cl)) +(autoload 'auth-source-user-or-password "auth-source") + +(defgroup nntp nil + "NNTP access for Gnus." + :group 'gnus) + (defvoo nntp-address nil "Address of the physical nntp server.") @@ -75,32 +87,59 @@ host. Direct connections: - `nntp-open-network-stream' (the default), - `nntp-open-ssl-stream', +- `nntp-open-tls-stream', +- `nntp-open-netcat-stream'. - `nntp-open-telnet-stream'. Indirect connections: +- `nntp-open-via-rlogin-and-netcat', - `nntp-open-via-rlogin-and-telnet', - `nntp-open-via-telnet-and-telnet'.") +(defvoo nntp-never-echoes-commands nil + "*Non-nil means the nntp server never echoes commands. +It is reported that some nntps server doesn't echo commands. So, you +may want to set this to non-nil in the method for such a server setting +`nntp-open-connection-function' to `nntp-open-ssl-stream' for example. +Note that the `nntp-open-connection-functions-never-echo-commands' +variable overrides the nil value of this variable.") + +(defvoo nntp-open-connection-functions-never-echo-commands + '(nntp-open-network-stream) + "*List of functions that never echo commands. +Add or set a function which you set to `nntp-open-connection-function' +to this list if it does not echo commands. Note that a non-nil value +of the `nntp-never-echoes-commands' variable overrides this variable.") + (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.") +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-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-*).") +This is \"\\r\\n\" by default, but should be \"\\n\" when using an 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.") +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-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-via-telnet-command "telnet" "*Telnet command used to connect to an intermediate host. @@ -109,9 +148,17 @@ 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-netcat-command "nc" + "*Netcat command used to connect to the nntp server. +This command is used by the `nntp-open-netcat-stream' and +`nntp-open-via-rlogin-and-netcat' methods.") + +(defvoo nntp-netcat-switches nil + "*Switches given to the netcat command `nntp-netcat-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.") +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. @@ -119,8 +166,7 @@ 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.") +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. @@ -131,8 +177,8 @@ If non-nil, there will be no prompt for a login name.") 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 @@ -154,6 +200,14 @@ by one.") If the gap between two consecutive articles is bigger than this variable, split the XOVER request into two requests.") +(defvoo nntp-xref-number-is-evil nil + "*If non-nil, Gnus never trusts article numbers in the Xref header. +Some news servers, e.g., ones running Diablo, run multiple engines +having the same articles but article numbers are not kept synchronized +between them. If you connect to such a server, set this to a non-nil +value, and Gnus never uses article numbers (that appear in the Xref +header and vary by which engine is chosen) to refer to articles.") + (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 @@ -163,17 +217,30 @@ 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.") - (defvoo nntp-coding-system-for-read 'binary "*Coding system to read from NNTP.") (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 'nntp + :type 'directory) + (defcustom nntp-authinfo-file "~/.authinfo" ".netrc-like file that holds nntp authinfo passwords." + :group 'nntp :type '(choice file (repeat :tag "Entries" @@ -217,6 +284,7 @@ to insert Cancel-Lock headers.") (defvoo nntp-last-command nil) (defvoo nntp-authinfo-password nil) (defvoo nntp-authinfo-user nil) +(defvoo nntp-authinfo-force nil) (defvar nntp-connection-list nil) @@ -230,19 +298,22 @@ to insert Cancel-Lock headers.") (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")) +(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.") + +(defvar nntp-authinfo-rejected nil +"A custom error condition used to report 'Authentication Rejected' errors. +Condition handlers that match just this condition ensure that the nntp +backend doesn't catch this error.") +(put 'nntp-authinfo-rejected 'error-conditions '(error nntp-authinfo-rejected)) +(put 'nntp-authinfo-rejected 'error-message "Authorization Rejected") @@ -257,30 +328,82 @@ 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." - (save-excursion - (set-buffer (get-buffer-create "*nntp-log*")) + (with-current-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")))) +(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)) + +(defmacro nntp-insert-buffer-substring (buffer &optional start end) + "Copy string from unibyte buffer to multibyte current buffer." + (if (featurep 'xemacs) + `(insert-buffer-substring ,buffer ,start ,end) + `(if enable-multibyte-characters + (insert (with-current-buffer ,buffer + (mm-string-to-multibyte + ,(if (or start end) + `(buffer-substring (or ,start (point-min)) + (or ,end (point-max))) + '(buffer-string))))) + (insert-buffer-substring ,buffer ,start ,end)))) + +(defmacro nntp-copy-to-buffer (buffer start end) + "Copy string from unibyte current buffer to multibyte buffer." + (if (featurep 'xemacs) + `(copy-to-buffer ,buffer ,start ,end) + `(let ((string (buffer-substring ,start ,end))) + (with-current-buffer ,buffer + (erase-buffer) + (insert (if enable-multibyte-characters + (mm-string-to-multibyte string) + string)) + (goto-char (point-min)) + nil)))) + (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)) + + (with-current-buffer (process-buffer process) (goto-char (point-min)) + (while (and (or (not (memq (char-after (point)) '(?2 ?3 ?4 ?5))) - (looking-at "480")) + (looking-at "48[02]")) (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)))) + (cond ((looking-at "480") + (nntp-handle-authinfo process)) + ((looking-at "482") + (nnheader-report 'nntp (get 'nntp-authinfo-rejected 'error-message)) + (signal 'nntp-authinfo-rejected nil)) + ((looking-at "^.*\n") + (delete-region (point) (progn (forward-line 1) (point))))) (nntp-accept-process-output process) (goto-char (point-min))) (prog1 @@ -290,7 +413,7 @@ 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)) @@ -306,10 +429,9 @@ noticing asynchronous data.") (setq nntp-process-response response))) (nntp-decode-text (not decode)) (unless discard - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (goto-char (point-max)) - (insert-buffer-substring (process-buffer process)) + (nntp-insert-buffer-substring (process-buffer process)) ;; Nix out "nntp reading...." message. (when nntp-have-messaged (setq nntp-have-messaged nil) @@ -323,6 +445,11 @@ 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) @@ -354,116 +481,131 @@ 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))) + (nntp-authinfo-rejected + (signal 'nntp-authinfo-rejected (cdr err))) + (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-erase-buffer nntp-server-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)))) - ))) - )) + (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 echoes if `nntp-never-echoes-commands' is non-nil + ;; or the value of `nntp-open-connection-function' is in + ;; `nntp-open-connection-functions-never-echo-commands', so we + ;; skip this in that cases. + (unless (or wait-for + nntp-never-echoes-commands + (memq + nntp-open-connection-function + nntp-open-connection-functions-never-echo-commands)) + (nntp-accept-response) + (with-current-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." (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)))) - ))) - )) + (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) + (with-current-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-erase-buffer nntp-server-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)))) - ))) - )) + (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) + (with-current-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) - (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))) + ;; Make sure we did not forget to encode some of the content. + (assert (save-excursion (goto-char (point-min)) + (not (re-search-forward "[^\000-\377]" nil t)))) + (mm-disable-multibyte) + (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)) @@ -480,7 +622,12 @@ noticing asynchronous data.") ;; a line with only a "." on it. ((eq (char-after) ?2) (if (re-search-forward "\n\\.\r?\n" nil t) - t + (progn + ;; Some broken news servers add another dot at the end. + ;; Protect against inflooping there. + (while (looking-at "^\\.\r?\n") + (forward-line 1)) + t) nil)) ;; A result that starts with a 3xx or 4xx code is terminated ;; by a newline. @@ -492,223 +639,305 @@ noticing asynchronous data.") (t nil))) +(eval-when-compile + (defvar nntp-with-open-group-internal nil) + (defvar nntp-report-n nil)) + +(defun nntp-with-open-group-function (-group -server -connectionless -bodyfun) + "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." + (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 + (funcall -bodyfun) + (quit + (unless debug-on-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)) + +(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." + (declare (indent 2) (debug (form form [&optional symbolp] def-body))) + (when (and (listp connectionless) + (not (eq connectionless nil))) + (setq forms (cons connectionless forms) + connectionless nil)) + `(nntp-with-open-group-function ,group ,server ,connectionless (lambda () ,@forms))) + (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 + (with-current-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) + (nntp-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)))))) + (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 + (nntp-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)))) + (nntp-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 + (nntp-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) + (with-current-buffer nntp-server-buffer (goto-char (point-min)) (cond ((or (eobp) (looking-at "5[0-9]+")) @@ -718,47 +947,52 @@ 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))) + (with-current-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))) - -(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 + 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 info) + (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) @@ -780,7 +1014,8 @@ noticing asynchronous data.") (unless (assq 'nntp-address defs) (setq defs (append defs (list (list 'nntp-address server))))) (nnoo-change-server 'nntp server defs) - (unless connectionless + (if connectionless + t (or (nntp-find-connection nntp-server-buffer) (nntp-open-connection nntp-server-buffer))))) @@ -816,54 +1051,57 @@ 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) - (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))))) + (nntp-with-open-group + nil server + (with-current-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 (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")))) + (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) @@ -871,6 +1109,56 @@ noticing asynchronous data.") (deffoo nntp-asynchronous-p () t) +(deffoo nntp-request-set-mark (group actions &optional server) + (when (and (not nntp-marks-is-evil) + nntp-marks-file-name) + (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-marks (group info &optional server) + (when (and (not nntp-marks-is-evil) + nntp-marks-file-name) + (nntp-possibly-create-directory group server) + (when (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))) + nil) + + + ;;; Hooky functions. (defun nntp-send-mode-reader () @@ -880,6 +1168,11 @@ It will make innd servers spawn an nnrpd process to allow actual article reading." (nntp-send-command "^.*\n" "MODE READER")) +(declare-function netrc-parse "netrc" (file)) +(declare-function netrc-machine "netrc" + (list machine &optional port defaultport)) +(declare-function netrc-get "netrc" (alist type)) + (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 @@ -888,11 +1181,23 @@ 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"))) + (require 'netrc) + (let* ((list (netrc-parse nntp-authinfo-file)) + (alist (netrc-machine list nntp-address "nntp")) + (force (or (netrc-get alist "force") nntp-authinfo-force)) + (auth-info + (auth-source-user-or-password '("login" "password") nntp-address "nntp")) + (auth-user (nth 0 auth-info)) + (auth-passwd (nth 1 auth-info)) + (user (or + ;; this is preferred to netrc-* + auth-user + (netrc-get alist "login") + nntp-authinfo-user)) + (passwd (or + ;; this is preferred to netrc-* + auth-passwd + (netrc-get alist "password")))) (when (or (not send-if-force) force) (unless user @@ -906,9 +1211,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." @@ -917,8 +1221,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. @@ -932,7 +1236,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. @@ -942,20 +1246,17 @@ 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) "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)))) - (mm-enable-multibyte) + (with-current-buffer + (generate-new-buffer + (format " *server %s %s %s*" + nntp-address nntp-port-number + (gnus-buffer-exists-p buffer))) + (mm-disable-multibyte) (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) @@ -970,7 +1271,7 @@ password contained in '~/.nntp-authinfo'." (let* ((pbuffer (nntp-make-process-buffer buffer)) (timer (and nntp-connection-timeout - (nnheader-run-at-time + (run-at-time nntp-connection-timeout nil `(lambda () (nntp-kill-buffer ,pbuffer))))) @@ -981,7 +1282,7 @@ password contained in '~/.nntp-authinfo'." (funcall nntp-open-connection-function pbuffer)) (error nil) (quit - (message "Quit opening connection") + (message "Quit opening connection to %s" nntp-address) (nntp-kill-buffer pbuffer) (signal 'quit nil) nil)))) @@ -991,14 +1292,13 @@ password contained in '~/.nntp-authinfo'." (nntp-kill-buffer pbuffer)) (when (and (buffer-name pbuffer) process) - (process-kill-without-query process) + (gnus-set-process-query-on-exit-flag process nil) (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) + (with-current-buffer pbuffer (nntp-read-server-type) (erase-buffer) (set-buffer nntp-server-buffer) @@ -1011,11 +1311,33 @@ password contained in '~/.nntp-authinfo'." (defun nntp-open-network-stream (buffer) (open-network-stream "nntpd" buffer nntp-address nntp-port-number)) +(autoload 'format-spec "format-spec") +(autoload 'format-spec-make "format-spec") +(autoload 'open-tls-stream "tls") + (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]") + (let* ((process-connection-type nil) + (proc (start-process "nntpd" buffer + shell-file-name + shell-command-switch + (format-spec nntp-ssl-program + (format-spec-make + ?s nntp-address + ?p nntp-port-number))))) + (gnus-set-process-query-on-exit-flag proc nil) + (with-current-buffer buffer + (let ((nntp-connection-alist (list proc buffer nil))) + (nntp-wait-for-string "^\r*20[01]")) + (beginning-of-line) + (delete-region (point-min) (point)) + proc))) + +(defun nntp-open-tls-stream (buffer) + (let ((proc (open-tls-stream "nntpd" buffer nntp-address nntp-port-number))) + (gnus-set-process-query-on-exit-flag proc nil) + (with-current-buffer buffer + (let ((nntp-connection-alist (list proc buffer nil))) + (nntp-wait-for-string "^\r*20[01]")) (beginning-of-line) (delete-region (point-min) (point)) proc))) @@ -1024,12 +1346,9 @@ password contained in '~/.nntp-authinfo'." "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) + (let ((case-fold-search t)) ;; Run server-specific commands. - (while alist - (setq entry (pop alist)) + (dolist (entry nntp-server-action-alist) (when (string-match (car entry) nntp-server-type) (if (and (listp (cadr entry)) (not (eq 'lambda (caadr entry)))) @@ -1037,8 +1356,7 @@ password contained in '~/.nntp-authinfo'." (funcall (cadr entry))))))) (defun nntp-async-wait (process wait-for buffer decode callback) - (save-excursion - (set-buffer (process-buffer process)) + (with-current-buffer (process-buffer process) (unless nntp-inside-change-function (erase-buffer)) (setq nntp-process-wait-for wait-for @@ -1046,17 +1364,7 @@ password contained in '~/.nntp-authinfo'." 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)) + (setq after-change-functions '(nntp-after-change-function)))) (defun nntp-async-timer-handler () (mapcar @@ -1086,8 +1394,7 @@ password contained in '~/.nntp-authinfo'." (setq after-change-functions '(nntp-after-change-function))))) (defun nntp-async-trigger (process) - (save-excursion - (set-buffer (process-buffer process)) + (with-current-buffer (process-buffer process) (when nntp-process-callback ;; do we have an error message? (goto-char nntp-process-start-point) @@ -1112,12 +1419,11 @@ password contained in '~/.nntp-authinfo'." (let ((buf (current-buffer)) (start nntp-process-start-point) (decode nntp-process-decode)) - (save-excursion - (set-buffer nntp-process-to-buffer) + (with-current-buffer nntp-process-to-buffer (goto-char (point-max)) (save-restriction (narrow-to-region (point) (point)) - (insert-buffer-substring buf start) + (nntp-insert-buffer-substring buf start) (when decode (nntp-decode-text)))))) ;; report it. @@ -1139,17 +1445,24 @@ password contained in '~/.nntp-authinfo'." (nnheader-report 'nntp message) message)) -(defun nntp-accept-process-output (process &optional timeout) +(defun nntp-accept-process-output (process) "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)) + (with-current-buffer (or (nntp-find-connection-buffer nntp-server-buffer) + nntp-server-buffer) + (let ((len (/ (buffer-size) 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)))) + (prog1 + (nnheader-accept-process-output process) + ;; accept-process-output may update status of process to indicate + ;; that the server has closed the connection. This MUST be + ;; handled here as the buffer restored by the save-excursion may + ;; be the process's former output buffer (i.e. now killed) + (or (and process + (memq (process-status process) '(open run))) + (nntp-report "Server closed connection"))))) (defun nntp-accept-response () "Wait for output from the process that outputs to BUFFER." @@ -1167,13 +1480,15 @@ password contained in '~/.nntp-authinfo'." (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)))))) + (cond ((not entry) + (nntp-report "Server closed connection")) + ((not (equal group (caddr entry))) + (with-current-buffer (process-buffer (car entry)) + (erase-buffer) + (nntp-send-command "^[245].*\n" "GROUP" group) + (setcar (cddr entry) group) + (erase-buffer) + (nntp-erase-buffer nntp-server-buffer))))))) (defun nntp-decode-text (&optional cr-only) "Decode the text in the current buffer." @@ -1257,7 +1572,7 @@ password contained in '~/.nntp-authinfo'." in-process-buffer-p (buf nntp-server-buffer) (process-buffer (nntp-find-connection-buffer nntp-server-buffer)) - first) + first last status) ;; 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. @@ -1270,8 +1585,8 @@ password contained in '~/.nntp-authinfo'." (setq articles (cdr articles))) (setq in-process-buffer-p (stringp nntp-server-xover)) - (nntp-send-xover-command first (car articles)) - (setq articles (cdr articles)) + (nntp-send-xover-command first (setq last (car articles))) + (setq articles (cdr articles)) (when (and nntp-server-xover in-process-buffer-p) ;; Don't count tried request. @@ -1280,7 +1595,7 @@ password contained in '~/.nntp-authinfo'." ;; 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))) + (= 1 (% count nntp-maximum-request))) (nntp-accept-response) ;; On some Emacs versions the preceding function has a @@ -1291,33 +1606,52 @@ password contained in '~/.nntp-authinfo'." (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)) + (while (re-search-forward "^\\([0-9][0-9][0-9]\\) .*\n" + nil t) + (incf received) + (setq status (match-string 1)) + (if (string-match "^[45]" status) + (setq status 'error) + (setq status 'ok))) (setq last-point (point)) - (< received count)) + (or (< received count) + (if (eq status 'error) + nil + ;; I haven't started reading the final response + (progn + (goto-char (point-max)) + (forward-line -1) + (not (looking-at "^\\.\r?\n")))))) + ;; I haven't read the end of the final response (nntp-accept-response) - (set-buffer process-buffer)) - (set-buffer buf)))) + (set-buffer process-buffer)))) + + ;; Some nntp servers seem to have an extension to the XOVER + ;; extension. On these servers, requesting an article range + ;; preceeding the active range does not return an error as + ;; specified in the RFC. What we instead get is the NOV entry + ;; for the first available article. Obviously, a client can + ;; use that entry to avoid making unnecessary requests. The + ;; only problem is for a client that assumes that the response + ;; will always be within the requested ranage. For such a + ;; client, we can get N copies of the same entry (one for each + ;; XOVER command sent to the server). + + (when (<= count 1) + (goto-char (point-min)) + (when (re-search-forward "^[0-9][0-9][0-9] .*\n\\([0-9]+\\)" nil t) + (let ((low-limit (string-to-number + (buffer-substring (match-beginning 1) + (match-end 1))))) + (while (and articles (<= (car articles) low-limit)) + (setq articles (cdr articles)))))) + (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) + (nntp-insert-buffer-substring process-buffer) (set-buffer process-buffer) (erase-buffer) (set-buffer buf)) @@ -1349,8 +1683,7 @@ password contained in '~/.nntp-authinfo'." ;; 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) + (with-current-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 @@ -1358,62 +1691,85 @@ password contained in '~/.nntp-authinfo'." ;; article number. How... helpful. (progn (forward-line 1) - (looking-at "[0-9]+\t...")) ; More text after number. + ;; More text after number, or a dot. + (looking-at "[0-9]+\t...\\|\\.\r?\n")) (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)))) + (nntp-erase-buffer nntp-server-buffer) + (setq nntp-server-xover nil)) + nntp-server-xover)))) -(defun nntp-find-group-and-number () +(defun nntp-find-group-and-number (&optional group) (save-excursion (save-restriction + ;; FIXME: This is REALLY FISHY: set-buffer after 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 + (string-to-number (buffer-substring (match-beginning 1) (match-end 1))))) - group newsgroups xref) + 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 ""))) + (if number + ;; 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)) + (match-string 1 xref)) + (t ""))) + (cond + ((and (not nntp-xref-number-is-evil) + (setq xref (mail-fetch-field "xref")) + (string-match + (if group + (concat "\\(" (regexp-quote group) "\\):\\([0-9]+\\)") + "\\([^ :]+\\):\\([0-9]+\\)") + xref)) + (setq group (match-string 1 xref) + number (string-to-number (match-string 2 xref)))) + ((and (setq newsgroups + (mail-fetch-field "newsgroups")) + (not (string-match "," newsgroups))) + (setq group newsgroups)) + (group) + (t (setq group "")))) (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))) + (let ((buf (current-buffer)) + proc) (goto-char (point-min)) - (while (not (re-search-forward regexp nil t)) - (accept-process-output (nntp-find-connection nntp-server-buffer)) + (while (and (setq proc (get-buffer-process buf)) + (memq (process-status proc) '(open run)) + (not (re-search-forward regexp nil t))) + (accept-process-output proc 0.1) (set-buffer buf) (goto-char (point-min))))) @@ -1453,9 +1809,21 @@ via telnet.") (defvoo nntp-telnet-passwd nil "Password to use to log in via telnet with.") +(defun nntp-service-to-port (svc) + (cond + ((integerp svc) (number-to-string svc)) + ((string-match "\\`[0-9]+\\'" svc) svc) + (t + (with-temp-buffer + (ignore-errors (insert-file-contents "/etc/services")) + (goto-char (point-min)) + (if (re-search-forward (concat "^" (regexp-quote svc) + "[ \t]+\\([0-9]+\\)/tcp")) + (match-string 1) + svc))))) + (defun nntp-open-telnet (buffer) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (erase-buffer) (let ((proc (apply 'start-process @@ -1483,7 +1851,7 @@ via telnet.") proc (concat (or nntp-telnet-passwd (setq nntp-telnet-passwd - (mail-source-read-passwd "Password: "))) + (read-passwd "Password: "))) "\n")) (nntp-wait-for-string nntp-telnet-shell-prompt) (process-send-string @@ -1511,8 +1879,7 @@ via telnet.") (apply 'start-process "nntpd" buffer nntp-rlogin-program nntp-address nntp-rlogin-parameters)))) - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (nntp-wait-for-string "^\r*20[01]") (beginning-of-line) (delete-region (point-min) (point)) @@ -1525,6 +1892,8 @@ via telnet.") (defun nntp-open-telnet-stream (buffer) "Open a nntp connection by telnet'ing the news server. +`nntp-open-netcat-stream' is recommended in place of this function +because it is more reliable. Please refer to the following variables to customize the connection: - `nntp-pre-command', @@ -1535,13 +1904,13 @@ Please refer to the following variables to customize the connection: - `nntp-end-of-line'." (let ((command `(,nntp-telnet-command ,@nntp-telnet-switches - ,nntp-address ,nntp-port-number)) + ,nntp-address + ,(nntp-service-to-port 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) + (with-current-buffer buffer (nntp-wait-for-string "^\r*20[01]") (beginning-of-line) (delete-region (point-min) (point)) @@ -1551,10 +1920,13 @@ Please refer to the following variables to customize the connection: "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. +`nntp-open-via-rlogin-and-netcat' is recommended in place of this function +because it is more reliable. Please refer to the following variables to customize the connection: - `nntp-pre-command', - `nntp-via-rlogin-command', +- `nntp-via-rlogin-command-switches', - `nntp-via-user-name', - `nntp-via-address', - `nntp-telnet-command', @@ -1564,21 +1936,85 @@ Please refer to the following variables to customize the connection: - `nntp-end-of-line'." (let ((command `(,nntp-via-address ,nntp-telnet-command - ,@nntp-telnet-switches - ,nntp-address ,nntp-port-number)) + ,@nntp-telnet-switches)) proc) - (and nntp-via-user-name - (setq command `("-l" ,nntp-via-user-name ,@command))) + (when nntp-via-user-name + (setq command `("-l" ,nntp-via-user-name ,@command))) + (when nntp-via-rlogin-command-switches + (setq command (append nntp-via-rlogin-command-switches 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) + (with-current-buffer buffer + (nntp-wait-for-string "^r?telnet") + (process-send-string proc (concat "open " nntp-address " " + (nntp-service-to-port nntp-port-number) + "\n")) (nntp-wait-for-string "^\r*20[01]") (beginning-of-line) (delete-region (point-min) (point)) - proc))) + (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-via-rlogin-and-netcat (buffer) + "Open a connection to an nntp server through an intermediate host. +First rlogin to the remote host, and then connect to the real news +server from there using the netcat command. + +Please refer to the following variables to customize the connection: +- `nntp-pre-command', +- `nntp-via-rlogin-command', +- `nntp-via-rlogin-command-switches', +- `nntp-via-user-name', +- `nntp-via-address', +- `nntp-netcat-command', +- `nntp-netcat-switches', +- `nntp-address', +- `nntp-port-number'." + (let ((command `(,@(when nntp-pre-command + (list nntp-pre-command)) + ,nntp-via-rlogin-command + ,@nntp-via-rlogin-command-switches + ,@(when nntp-via-user-name + (list "-l" nntp-via-user-name)) + ,nntp-via-address + ,nntp-netcat-command + ,@nntp-netcat-switches + ,nntp-address + ,(nntp-service-to-port nntp-port-number)))) + ;; A non-nil connection type results in mightily odd behavior where + ;; (process-send-string proc "\^M") ends up sending a "\n" to the + ;; ssh process. --Stef + ;; Also a nil connection allow ssh-askpass to work under X11. + (let ((process-connection-type nil)) + (apply 'start-process "nntpd" buffer command)))) + +(defun nntp-open-netcat-stream (buffer) + "Open a connection to an nntp server through netcat. +I.e. use the `nc' command rather than Emacs's builtin networking code. + +Please refer to the following variables to customize the connection: +- `nntp-pre-command', +- `nntp-netcat-command', +- `nntp-netcat-switches', +- `nntp-address', +- `nntp-port-number'." + (let ((command `(,nntp-netcat-command + ,@nntp-netcat-switches + ,nntp-address + ,(nntp-service-to-port nntp-port-number)))) + (and nntp-pre-command (push nntp-pre-command command)) + (let ((process-connection-type nil)) ;See `nntp-open-via-rlogin-and-netcat'. + (apply 'start-process "nntpd" buffer command)))) + (defun nntp-open-via-telnet-and-telnet (buffer) "Open a connection to an nntp server through an intermediate host. @@ -1599,8 +2035,7 @@ Please refer to the following variables to customize the connection: - `nntp-address', - `nntp-port-number', - `nntp-end-of-line'." - (save-excursion - (set-buffer buffer) + (with-current-buffer buffer (erase-buffer) (let ((command `(,nntp-via-telnet-command ,@nntp-via-telnet-switches)) (case-fold-search t) @@ -1630,15 +2065,14 @@ Please refer to the following variables to customize the connection: (concat (or nntp-via-user-password (setq nntp-via-user-password - (mail-source-read-passwd - "Password: "))) + (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))) + ,(nntp-service-to-port nntp-port-number)))) (process-send-string proc (concat (mapconcat 'identity real-telnet-command " ") @@ -1656,6 +2090,95 @@ Please refer to the following variables to customize the connection: (delete-region (point) (point-max))) proc))) +;; Marks handling + +(defun nntp-marks-directory (server) + (expand-file-name server nntp-marks-directory)) + +(defvar nntp-server-to-method-cache nil + "Alist of servers and select methods.") + +(defun nntp-group-pathname (server group &optional file) + "Return an absolute file name of FILE for GROUP on SERVER." + (let ((method (cdr (assoc server nntp-server-to-method-cache)))) + (unless method + (push (cons server (setq method (or (gnus-server-to-method server) + (gnus-find-method-for-group group)))) + nntp-server-to-method-cache)) + (nnmail-group-pathname + (mm-decode-coding-string group + (inline (gnus-group-name-charset method group))) + (nntp-marks-directory server) + file))) + +(defun nntp-possibly-create-directory (group server) + (let ((dir (nntp-group-pathname server group)) + (file-name-coding-system nnmail-pathname-coding-system)) + (unless (file-exists-p dir) + (make-directory (directory-file-name dir) t) + (nnheader-message 5 "Creating nntp marks directory %s" dir)))) + +(autoload 'time-less-p "time-date") + +(defun nntp-marks-changed-p (group server) + (let ((file (nntp-group-pathname server group nntp-marks-file-name)) + (file-name-coding-system nnmail-pathname-coding-system)) + (if (null (gnus-gethash file nntp-marks-modtime)) + t ;; never looked at marks file, assume it has changed + (time-less-p (gnus-gethash file nntp-marks-modtime) + (nth 5 (file-attributes file)))))) + +(defun nntp-save-marks (group server) + (let ((file-name-coding-system nnmail-pathname-coding-system) + (file (nntp-group-pathname server group nntp-marks-file-name))) + (condition-case err + (progn + (nntp-possibly-create-directory group server) + (with-temp-file file + (erase-buffer) + (gnus-prin1 nntp-marks) + (insert "\n")) + (gnus-sethash file + (nth 5 (file-attributes file)) + nntp-marks-modtime)) + (error (or (gnus-yes-or-no-p + (format "Could not write to %s (%s). Continue? " file err)) + (error "Cannot write to %s (%s)" file err)))))) + +(defun nntp-open-marks (group server) + (let ((file (nntp-group-pathname server group nntp-marks-file-name)) + (file-name-coding-system nnmail-pathname-coding-system)) + (if (file-exists-p file) + (condition-case err + (with-temp-buffer + (gnus-sethash file (nth 5 (file-attributes file)) + nntp-marks-modtime) + (nnheader-insert-file-contents file) + (setq nntp-marks (read (current-buffer))) + (dolist (el gnus-article-unpropagated-mark-lists) + (setq nntp-marks (gnus-remassoc el nntp-marks)))) + (error (or (gnus-yes-or-no-p + (format "Error reading nntp marks file %s (%s). Continuing will use marks from .newsrc.eld. Continue? " file err)) + (error "Cannot read nntp marks file %s (%s)" file err)))) + ;; User didn't have a .marks file. Probably first time + ;; user of the .marks stuff. Bootstrap it from .newsrc.eld. + (let ((info (gnus-get-info + (gnus-group-prefixed-name + group + (gnus-server-to-method (format "nntp:%s" server))))) + (decoded-name (mm-decode-coding-string + group + (gnus-group-name-charset + (gnus-server-to-method server) group)))) + (nnheader-message 7 "Bootstrapping marks for %s..." decoded-name) + (setq nntp-marks (gnus-info-marks info)) + (push (cons 'read (gnus-info-read info)) nntp-marks) + (dolist (el gnus-article-unpropagated-mark-lists) + (setq nntp-marks (gnus-remassoc el nntp-marks))) + (nntp-save-marks group server) + (nnheader-message 7 "Bootstrapping marks for %s...done" + decoded-name))))) + (provide 'nntp) ;;; nntp.el ends here