cgit.sxemacs.org Git - gnus/blob - lisp/nntp.el

   1 ;;; nntp.el --- nntp access for Gnus
   2
   3 ;; Copyright (C) 1987-1990, 1992-1998, 2000-2013 Free Software
   4 ;; Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; Keywords: news
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 ;; For Emacs <22.2 and XEmacs.
  29 (eval-and-compile
  30   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))
  31   ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for
  32   ;; `make-network-stream'.
  33   (unless (fboundp 'open-protocol-stream)
  34     (require 'proto-stream)))
  35
  36 (require 'nnheader)
  37 (require 'nnoo)
  38 (require 'gnus-util)
  39 (require 'gnus)
  40 (require 'gnus-group) ;; gnus-group-name-charset
  41
  42 (nnoo-declare nntp)
  43
  44 (eval-when-compile (require 'cl))
  45
  46 (autoload 'auth-source-search "auth-source")
  47
  48 (defgroup nntp nil
  49   "NNTP access for Gnus."
  50   :group 'gnus)
  51
  52 (defvoo nntp-address nil
  53   "Address of the physical nntp server.")
  54
  55 (defvoo nntp-port-number "nntp"
  56   "Port number on the physical nntp server.")
  57
  58 (defvoo nntp-server-opened-hook '(nntp-send-mode-reader)
  59   "*Hook used for sending commands to the server at startup.
  60 The default value is `nntp-send-mode-reader', which makes an innd
  61 server spawn an nnrpd server.")
  62
  63 (defvoo nntp-authinfo-function 'nntp-send-authinfo
  64   "Function used to send AUTHINFO to the server.
  65 It is called with no parameters.")
  66
  67 (defvoo nntp-server-action-alist
  68     '(("nntpd 1\\.5\\.11t"
  69        (remove-hook 'nntp-server-opened-hook 'nntp-send-mode-reader))
  70       ("NNRP server Netscape"
  71        (setq nntp-server-list-active-group nil)))
  72   "Alist of regexps to match on server types and actions to be taken.
  73 For instance, if you want Gnus to beep every time you connect
  74 to innd, you could say something like:
  75
  76 \(setq nntp-server-action-alist
  77        '((\"innd\" (ding))))
  78
  79 You probably don't want to do that, though.")
  80
  81 (defvoo nntp-open-connection-function 'nntp-open-network-stream
  82   "Method for connecting to a remote system.
  83 It should be a function, which is called with the output buffer
  84 as its single argument, or one of the following special values:
  85
  86 - `nntp-open-network-stream' specifies a network connection,
  87   upgrading to a TLS connection via STARTTLS if possible.
  88 - `nntp-open-plain-stream' specifies an unencrypted network
  89   connection (no STARTTLS upgrade is attempted).
  90 - `nntp-open-ssl-stream' or `nntp-open-tls-stream' specify a TLS
  91   network connection.
  92
  93 Apart from the above special values, valid functions are as
  94 follows; please refer to their respective doc string for more
  95 information.
  96 For direct connections:
  97 - `nntp-open-netcat-stream'
  98 - `nntp-open-telnet-stream'
  99 For indirect connections:
 100 - `nntp-open-via-rlogin-and-netcat'
 101 - `nntp-open-via-rlogin-and-telnet'
 102 - `nntp-open-via-telnet-and-telnet'")
 103
 104 (defvoo nntp-never-echoes-commands nil
 105   "*Non-nil means the nntp server never echoes commands.
 106 It is reported that some nntps server doesn't echo commands.  So, you
 107 may want to set this to non-nil in the method for such a server setting
 108 `nntp-open-connection-function' to `nntp-open-ssl-stream' for example.
 109 Note that the `nntp-open-connection-functions-never-echo-commands'
 110 variable overrides the nil value of this variable.")
 111
 112 (defvoo nntp-open-connection-functions-never-echo-commands
 113     '(nntp-open-network-stream)
 114   "*List of functions that never echo commands.
 115 Add or set a function which you set to `nntp-open-connection-function'
 116 to this list if it does not echo commands.  Note that a non-nil value
 117 of the `nntp-never-echoes-commands' variable overrides this variable.")
 118
 119 (defvoo nntp-pre-command nil
 120   "*Pre-command to use with the various nntp-open-via-* methods.
 121 This is where you would put \"runsocks\" or stuff like that.")
 122
 123 (defvoo nntp-telnet-command "telnet"
 124   "*Telnet command used to connect to the nntp server.
 125 This command is used by the methods `nntp-open-telnet-stream',
 126 `nntp-open-via-rlogin-and-telnet' and `nntp-open-via-telnet-and-telnet'.")
 127
 128 (defvoo nntp-telnet-switches '("-8")
 129   "*Switches given to the telnet command `nntp-telnet-command'.")
 130
 131 (defvoo nntp-end-of-line "\r\n"
 132   "*String to use on the end of lines when talking to the NNTP server.
 133 This is \"\\r\\n\" by default, but should be \"\\n\" when using an indirect
 134 connection method (nntp-open-via-*).")
 135
 136 (defvoo nntp-via-rlogin-command "rsh"
 137   "*Rlogin command used to connect to an intermediate host.
 138 This command is used by the methods `nntp-open-via-rlogin-and-telnet'
 139 and `nntp-open-via-rlogin-and-netcat'.  The default is \"rsh\", but \"ssh\"
 140 is a popular alternative.")
 141
 142 (defvoo nntp-via-rlogin-command-switches nil
 143   "*Switches given to the rlogin command `nntp-via-rlogin-command'.
 144 If you use \"ssh\" for `nntp-via-rlogin-command', you may set this to
 145 \(\"-C\") in order to compress all data connections, otherwise set this
 146 to \(\"-t\" \"-e\" \"none\") or (\"-C\" \"-t\" \"-e\" \"none\") if the telnet
 147 command requires a pseudo-tty allocation on an intermediate host.")
 148
 149 (defvoo nntp-via-telnet-command "telnet"
 150   "*Telnet command used to connect to an intermediate host.
 151 This command is used by the `nntp-open-via-telnet-and-telnet' method.")
 152
 153 (defvoo nntp-via-telnet-switches '("-8")
 154   "*Switches given to the telnet command `nntp-via-telnet-command'.")
 155
 156 (defvoo nntp-netcat-command "nc"
 157   "*Netcat command used to connect to the nntp server.
 158 This command is used by the `nntp-open-netcat-stream' and
 159 `nntp-open-via-rlogin-and-netcat' methods.")
 160
 161 (defvoo nntp-netcat-switches nil
 162   "*Switches given to the netcat command `nntp-netcat-command'.")
 163
 164 (defvoo nntp-via-user-name nil
 165   "*User name to log in on an intermediate host with.
 166 This variable is used by the various nntp-open-via-* methods.")
 167
 168 (defvoo nntp-via-user-password nil
 169   "*Password to use to log in on an intermediate host with.
 170 This variable is used by the `nntp-open-via-telnet-and-telnet' method.")
 171
 172 (defvoo nntp-via-address nil
 173   "*Address of an intermediate host to connect to.
 174 This variable is used by the various nntp-open-via-* methods.")
 175
 176 (defvoo nntp-via-envuser nil
 177   "*Whether both telnet client and server support the ENVIRON option.
 178 If non-nil, there will be no prompt for a login name.")
 179
 180 (defvoo nntp-via-shell-prompt "bash\\|\$ *\r?$\\|> *\r?"
 181   "*Regular expression to match the shell prompt on an intermediate host.
 182 This variable is used by the `nntp-open-via-telnet-and-telnet' method.")
 183
 184 (defvoo nntp-large-newsgroup 50
 185   "*The number of articles which indicates a large newsgroup.
 186 If the number of articles is greater than the value, verbose
 187 messages will be shown to indicate the current status.")
 188
 189 (defvoo nntp-maximum-request 400
 190   "*The maximum number of the requests sent to the NNTP server at one time.
 191 If Emacs hangs up while retrieving headers, set the variable to a
 192 lower value.")
 193
 194 (defvoo nntp-nov-is-evil nil
 195   "*If non-nil, nntp will never attempt to use XOVER when talking to the server.")
 196
 197 (defvoo nntp-xover-commands '("XOVER" "XOVERVIEW")
 198   "*List of strings that are used as commands to fetch NOV lines from a server.
 199 The strings are tried in turn until a positive response is gotten.  If
 200 none of the commands are successful, nntp will just grab headers one
 201 by one.")
 202
 203 (defvoo nntp-nov-gap 5
 204   "*Maximum allowed gap between two articles.
 205 If the gap between two consecutive articles is bigger than this
 206 variable, split the XOVER request into two requests.")
 207
 208 (defvoo nntp-xref-number-is-evil nil
 209   "*If non-nil, Gnus never trusts article numbers in the Xref header.
 210 Some news servers, e.g., ones running Diablo, run multiple engines
 211 having the same articles but article numbers are not kept synchronized
 212 between them.  If you connect to such a server, set this to a non-nil
 213 value, and Gnus never uses article numbers (that appear in the Xref
 214 header and vary by which engine is chosen) to refer to articles.")
 215
 216 (defvoo nntp-prepare-server-hook nil
 217   "*Hook run before a server is opened.
 218 If can be used to set up a server remotely, for instance.  Say you
 219 have an account at the machine \"other.machine\".  This machine has
 220 access to an NNTP server that you can't access locally.  You could
 221 then use this hook to rsh to the remote machine and start a proxy NNTP
 222 server there that you can connect to.  See also
 223 `nntp-open-connection-function'")
 224
 225 (defcustom nntp-authinfo-file "~/.authinfo"
 226   ".netrc-like file that holds nntp authinfo passwords."
 227   :group 'nntp
 228   :type
 229   '(choice file
 230            (repeat :tag "Entries"
 231                    :menu-tag "Inline"
 232                    (list :format "%v"
 233                          :value ("" ("login" . "") ("password" . ""))
 234                          (string :tag "Host")
 235                          (checklist :inline t
 236                                     (cons :format "%v"
 237                                           (const :format "" "login")
 238                                           (string :format "Login: %v"))
 239                                     (cons :format "%v"
 240                                           (const :format "" "password")
 241                                           (string :format "Password: %v")))))))
 242
 243 (make-obsolete 'nntp-authinfo-file nil "Emacs 24.1")
 244
 245 \f
 246
 247 (defvoo nntp-connection-timeout nil
 248   "*Number of seconds to wait before an nntp connection times out.
 249 If this variable is nil, which is the default, no timers are set.
 250 NOTE: This variable is never seen to work in Emacs 20 and XEmacs 21.")
 251
 252 (defvoo nntp-prepare-post-hook nil
 253   "*Hook run just before posting an article.  It is supposed to be used
 254 to insert Cancel-Lock headers.")
 255
 256 (defvoo nntp-server-list-active-group 'try
 257   "If nil, then always use GROUP instead of LIST ACTIVE.
 258 This is usually slower, but on misconfigured servers that don't
 259 update their active files often, this can help.")
 260
 261 ;;; Internal variables.
 262
 263 (defvoo nntp-retrieval-in-progress nil)
 264 (defvar nntp-record-commands nil
 265   "*If non-nil, nntp will record all commands in the \"*nntp-log*\" buffer.")
 266
 267 (defvar nntp-have-messaged nil)
 268
 269 (defvar nntp-process-wait-for nil)
 270 (defvar nntp-process-to-buffer nil)
 271 (defvar nntp-process-callback nil)
 272 (defvar nntp-process-decode nil)
 273 (defvar nntp-process-start-point nil)
 274 (defvar nntp-inside-change-function nil)
 275 (defvoo nntp-last-command-time nil)
 276 (defvoo nntp-last-command nil)
 277 (defvoo nntp-authinfo-password nil)
 278 (defvoo nntp-authinfo-user nil)
 279 (defvoo nntp-authinfo-force nil)
 280
 281 (defvar nntp-connection-list nil)
 282
 283 (defvoo nntp-server-type nil)
 284 (defvoo nntp-connection-alist nil)
 285 (defvoo nntp-status-string "")
 286 (defconst nntp-version "nntp 5.0")
 287 (defvoo nntp-inhibit-erase nil)
 288 (defvoo nntp-inhibit-output nil)
 289
 290 (defvoo nntp-server-xover 'try)
 291
 292 (defvar nntp-async-timer nil)
 293 (defvar nntp-async-process-list nil)
 294
 295 (defvar nntp-authinfo-rejected nil
 296 "A custom error condition used to report 'Authentication Rejected' errors.
 297 Condition handlers that match just this condition ensure that the nntp
 298 backend doesn't catch this error.")
 299 (put 'nntp-authinfo-rejected 'error-conditions '(error nntp-authinfo-rejected))
 300 (put 'nntp-authinfo-rejected 'error-message "Authorization Rejected")
 301
 302 \f
 303
 304 ;;; Internal functions.
 305
 306 (defsubst nntp-send-string (process string)
 307   "Send STRING to PROCESS."
 308   ;; We need to store the time to provide timeouts, and
 309   ;; to store the command so the we can replay the command
 310   ;; if the server gives us an AUTHINFO challenge.
 311   (setq nntp-last-command-time (current-time)
 312         nntp-last-command string)
 313   (when nntp-record-commands
 314     (nntp-record-command string))
 315   (process-send-string process (concat string nntp-end-of-line))
 316   (or (memq (process-status process) '(open run))
 317       (nntp-report "Server closed connection")))
 318
 319 (defun nntp-record-command (string)
 320   "Record the command STRING."
 321   (with-current-buffer (get-buffer-create "*nntp-log*")
 322     (goto-char (point-max))
 323     (insert (format-time-string "%Y%m%dT%H%M%S.%3N")
 324             " " nntp-address " " string "\n")))
 325
 326 (defvar nntp--report-1 nil)
 327
 328 (defun nntp-report (&rest args)
 329   "Report an error from the nntp backend.  The first string in ARGS
 330 can be a format string.  For some commands, the failed command may be
 331 retried once before actually displaying the error report."
 332   (if nntp--report-1
 333       (progn
 334         ;; Throw out to nntp-with-open-group-error so that the connection may
 335         ;; be restored and the command retried."
 336         (when nntp-record-commands
 337           (nntp-record-command "*** CONNECTION LOST ***"))
 338         (throw 'nntp-with-open-group-error t))
 339
 340     (when nntp-record-commands
 341       (nntp-record-command "*** CALLED nntp-report ***"))
 342
 343     (nnheader-report 'nntp args)
 344
 345     (apply 'error args)))
 346
 347 (defmacro nntp-copy-to-buffer (buffer start end)
 348   "Copy string from unibyte current buffer to multibyte buffer."
 349   (if (featurep 'xemacs)
 350       `(copy-to-buffer ,buffer ,start ,end)
 351     `(let ((string (buffer-substring ,start ,end)))
 352        (with-current-buffer ,buffer
 353          (erase-buffer)
 354          (insert (if enable-multibyte-characters
 355                      (mm-string-to-multibyte string)
 356                    string))
 357          (goto-char (point-min))
 358          nil))))
 359
 360 (defsubst nntp-wait-for (process wait-for buffer &optional decode discard)
 361   "Wait for WAIT-FOR to arrive from PROCESS."
 362
 363   (with-current-buffer (process-buffer process)
 364     (goto-char (point-min))
 365
 366     (while (and (or (not (memq (char-after (point)) '(?2 ?3 ?4 ?5)))
 367                     (looking-at "48[02]"))
 368                 (memq (process-status process) '(open run)))
 369       (cond ((looking-at "480")
 370              (nntp-handle-authinfo process))
 371             ((looking-at "482")
 372              (nnheader-report 'nntp "%s"
 373                               (get 'nntp-authinfo-rejected 'error-message))
 374              (signal 'nntp-authinfo-rejected nil))
 375             ((looking-at "^.*\n")
 376              (delete-region (point) (progn (forward-line 1) (point)))))
 377       (nntp-accept-process-output process)
 378       (goto-char (point-min)))
 379     (prog1
 380         (cond
 381          ((looking-at "[45]")
 382           (progn
 383             (nntp-snarf-error-message)
 384             nil))
 385          ((not (memq (process-status process) '(open run)))
 386           (nntp-report "Server closed connection"))
 387          (t
 388           (goto-char (point-max))
 389           (let ((limit (point-min))
 390                 response)
 391             (while (not (re-search-backward wait-for limit t))
 392               (nntp-accept-process-output process)
 393               ;; We assume that whatever we wait for is less than 1000
 394               ;; characters long.
 395               (setq limit (max (- (point-max) 1000) (point-min)))
 396               (goto-char (point-max)))
 397             (setq response (match-string 0))
 398             (with-current-buffer nntp-server-buffer
 399               (setq nntp-process-response response)))
 400           (nntp-decode-text (not decode))
 401           (unless discard
 402             (with-current-buffer buffer
 403               (goto-char (point-max))
 404               (nnheader-insert-buffer-substring (process-buffer process))
 405               ;; Nix out "nntp reading...." message.
 406               (when nntp-have-messaged
 407                 (setq nntp-have-messaged nil)
 408                 (nnheader-message 5 ""))))
 409           t))
 410       (unless discard
 411         (erase-buffer)))))
 412
 413 (defun nntp-kill-buffer (buffer)
 414   (when (buffer-name buffer)
 415     (let ((process (get-buffer-process buffer)))
 416       (when process
 417         (delete-process process)))
 418     (kill-buffer buffer)
 419     (nnheader-init-server-buffer)))
 420
 421 (defun nntp-erase-buffer (buffer)
 422   "Erase contents of BUFFER."
 423   (with-current-buffer buffer
 424     (erase-buffer)))
 425
 426 (defsubst nntp-find-connection (buffer)
 427   "Find the connection delivering to BUFFER."
 428   (let ((alist nntp-connection-alist)
 429         (buffer (if (stringp buffer) (get-buffer buffer) buffer))
 430         process entry)
 431     (while (and alist (setq entry (pop alist)))
 432       (when (eq buffer (cadr entry))
 433         (setq process (car entry)
 434               alist nil)))
 435     (when process
 436       (if (memq (process-status process) '(open run))
 437           process
 438         (nntp-kill-buffer (process-buffer process))
 439         (setq nntp-connection-alist (delq entry nntp-connection-alist))
 440         nil))))
 441
 442 (defsubst nntp-find-connection-entry (buffer)
 443   "Return the entry for the connection to BUFFER."
 444   (assq (nntp-find-connection buffer) nntp-connection-alist))
 445
 446 (defun nntp-find-connection-buffer (buffer)
 447   "Return the process connection buffer tied to BUFFER."
 448   (let ((process (nntp-find-connection buffer)))
 449     (when process
 450       (process-buffer process))))
 451
 452 (defsubst nntp-retrieve-data (command address port buffer
 453                                       &optional wait-for callback decode)
 454   "Use COMMAND to retrieve data into BUFFER from PORT on ADDRESS."
 455   (let ((process (or (nntp-find-connection buffer)
 456                      (nntp-open-connection buffer))))
 457     (if process
 458         (progn
 459           (unless (or nntp-inhibit-erase nnheader-callback-function)
 460             (nntp-erase-buffer (process-buffer process)))
 461           (condition-case err
 462               (progn
 463                 (when command
 464                   (nntp-send-string process command))
 465                 (cond
 466                  ((eq callback 'ignore)
 467                   t)
 468                  ((and callback wait-for)
 469                   (nntp-async-wait process wait-for buffer decode callback)
 470                   t)
 471                  (wait-for
 472                   (nntp-wait-for process wait-for buffer decode))
 473                  (t t)))
 474             (nntp-authinfo-rejected
 475              (signal 'nntp-authinfo-rejected (cdr err)))
 476             (error
 477              (nnheader-report 'nntp "Couldn't open connection to %s: %s"
 478                               address err))
 479             (quit
 480              (message "Quit retrieving data from nntp")
 481              (signal 'quit nil)
 482              nil)))
 483       (nnheader-report 'nntp "Couldn't open connection to %s" address))))
 484
 485 (defsubst nntp-send-command (wait-for &rest strings)
 486   "Send STRINGS to server and wait until WAIT-FOR returns."
 487   (when (and (not nnheader-callback-function)
 488              (not nntp-inhibit-output))
 489     (nntp-erase-buffer nntp-server-buffer))
 490   (let* ((command (mapconcat 'identity strings " "))
 491          (process (nntp-find-connection nntp-server-buffer))
 492          (buffer (and process (process-buffer process)))
 493          (pos (and buffer (with-current-buffer buffer (point)))))
 494     (if process
 495         (prog1
 496             (nntp-retrieve-data command
 497                                 nntp-address nntp-port-number
 498                                 nntp-server-buffer
 499                                 wait-for nnheader-callback-function)
 500           ;; If nothing to wait for, still remove possibly echo'ed commands.
 501           ;; We don't have echoes if `nntp-never-echoes-commands' is non-nil
 502           ;; or the value of `nntp-open-connection-function' is in
 503           ;; `nntp-open-connection-functions-never-echo-commands', so we
 504           ;; skip this in that cases.
 505           (unless (or wait-for
 506                       nntp-never-echoes-commands
 507                       (memq
 508                        nntp-open-connection-function
 509                        nntp-open-connection-functions-never-echo-commands))
 510             (nntp-accept-response)
 511             (with-current-buffer buffer
 512               (goto-char pos)
 513               (if (looking-at (regexp-quote command))
 514                   (delete-region pos (progn (forward-line 1)
 515                                             (point-at-bol)))))))
 516       (nnheader-report 'nntp "Couldn't open connection to %s."
 517                        nntp-address))))
 518
 519 (defun nntp-send-command-nodelete (wait-for &rest strings)
 520   "Send STRINGS to server and wait until WAIT-FOR returns."
 521   (let* ((command (mapconcat 'identity strings " "))
 522          (process (nntp-find-connection nntp-server-buffer))
 523          (buffer (and process (process-buffer process)))
 524          (pos (and buffer (with-current-buffer buffer (point)))))
 525     (if process
 526         (prog1
 527             (nntp-retrieve-data command
 528                                 nntp-address nntp-port-number
 529                                 nntp-server-buffer
 530                                 wait-for nnheader-callback-function)
 531           ;; If nothing to wait for, still remove possibly echo'ed commands
 532           (unless wait-for
 533             (nntp-accept-response)
 534             (with-current-buffer buffer
 535               (goto-char pos)
 536               (if (looking-at (regexp-quote command))
 537                   (delete-region pos (progn (forward-line 1)
 538                                             (point-at-bol)))))))
 539       (nnheader-report 'nntp "Couldn't open connection to %s."
 540                        nntp-address))))
 541
 542 (defun nntp-send-command-and-decode (wait-for &rest strings)
 543   "Send STRINGS to server and wait until WAIT-FOR returns."
 544   (when (and (not nnheader-callback-function)
 545              (not nntp-inhibit-output))
 546     (nntp-erase-buffer nntp-server-buffer))
 547   (let* ((command (mapconcat 'identity strings " "))
 548          (process (nntp-find-connection nntp-server-buffer))
 549          (buffer (and process (process-buffer process)))
 550          (pos (and buffer (with-current-buffer buffer (point)))))
 551     (if process
 552         (prog1
 553             (nntp-retrieve-data command
 554                                 nntp-address nntp-port-number
 555                                 nntp-server-buffer
 556                                 wait-for nnheader-callback-function t)
 557           ;; If nothing to wait for, still remove possibly echo'ed commands
 558           (unless wait-for
 559             (nntp-accept-response)
 560             (with-current-buffer buffer
 561               (goto-char pos)
 562               (if (looking-at (regexp-quote command))
 563                   (delete-region pos (progn (forward-line 1) (point-at-bol))))
 564               )))
 565       (nnheader-report 'nntp "Couldn't open connection to %s."
 566                        nntp-address))))
 567
 568
 569 (defun nntp-send-buffer (wait-for)
 570   "Send the current buffer to server and wait until WAIT-FOR returns."
 571   (when (and (not nnheader-callback-function)
 572              (not nntp-inhibit-output))
 573     (nntp-erase-buffer
 574      (nntp-find-connection-buffer nntp-server-buffer)))
 575   (nntp-encode-text)
 576   ;; Make sure we did not forget to encode some of the content.
 577   (assert (save-excursion (goto-char (point-min))
 578                           (not (re-search-forward "[^\000-\377]" nil t))))
 579   (mm-disable-multibyte)
 580   (process-send-region (nntp-find-connection nntp-server-buffer)
 581                        (point-min) (point-max))
 582   (nntp-retrieve-data
 583    nil nntp-address nntp-port-number nntp-server-buffer
 584    wait-for nnheader-callback-function))
 585
 586 \f
 587
 588 ;;; Interface functions.
 589
 590 (nnoo-define-basics nntp)
 591
 592 (defsubst nntp-next-result-arrived-p ()
 593   (cond
 594    ;; A result that starts with a 2xx code is terminated by
 595    ;; a line with only a "." on it.
 596    ((eq (char-after) ?2)
 597     (if (re-search-forward "\n\\.\r?\n" nil t)
 598         (progn
 599           ;; Some broken news servers add another dot at the end.
 600           ;; Protect against inflooping there.
 601           (while (looking-at "^\\.\r?\n")
 602             (forward-line 1))
 603           t)
 604       nil))
 605    ;; A result that starts with a 3xx or 4xx code is terminated
 606    ;; by a newline.
 607    ((looking-at "[34]")
 608     (if (search-forward "\n" nil t)
 609         t
 610       nil))
 611    ;; No result here.
 612    (t
 613     nil)))
 614
 615 (defun nntp-with-open-group-function (-group -server -connectionless -bodyfun)
 616   "Protect against servers that don't like clients that keep idle connections opens.
 617 The problem being that these servers may either close a connection or
 618 simply ignore any further requests on a connection.  Closed
 619 connections are not detected until `accept-process-output' has updated
 620 the `process-status'.  Dropped connections are not detected until the
 621 connection timeouts (which may be several minutes) or
 622 `nntp-connection-timeout' has expired.  When these occur
 623 `nntp-with-open-group', opens a new connection then re-issues the NNTP
 624 command whose response triggered the error."
 625   (let ((nntp-report-n nntp--report-1)
 626         (nntp--report-1 t)
 627         (nntp-with-open-group-internal nil))
 628     (while (catch 'nntp-with-open-group-error
 629              ;; Open the connection to the server
 630              ;; NOTE: Existing connections are NOT tested.
 631              (nntp-possibly-change-group -group -server -connectionless)
 632
 633              (let ((-timer
 634                     (and nntp-connection-timeout
 635                          (run-at-time
 636                           nntp-connection-timeout nil
 637                           (lambda ()
 638                             (let* ((-process (nntp-find-connection
 639                                              nntp-server-buffer))
 640                                    (-buffer  (and -process
 641                                                   (process-buffer -process))))
 642                               ;; When I an able to identify the
 643                               ;; connection to the server AND I've
 644                               ;; received NO response for
 645                               ;; nntp-connection-timeout seconds.
 646                               (when (and -buffer (eq 0 (buffer-size -buffer)))
 647                                 ;; Close the connection.  Take no
 648                                 ;; other action as the accept input
 649                                 ;; code will handle the closed
 650                                 ;; connection.
 651                                 (nntp-kill-buffer -buffer))))))))
 652                (unwind-protect
 653                    (setq nntp-with-open-group-internal
 654                          (condition-case nil
 655                              (funcall -bodyfun)
 656                            (quit
 657                             (unless debug-on-quit
 658                               (nntp-close-server))
 659                             (signal 'quit nil))))
 660                  (when -timer
 661                    (nnheader-cancel-timer -timer)))
 662                nil))
 663       (setq nntp--report-1 nntp-report-n))
 664     nntp-with-open-group-internal))
 665
 666 (defmacro nntp-with-open-group (group server &optional connectionless &rest forms)
 667   "Protect against servers that don't like clients that keep idle connections opens.
 668 The problem being that these servers may either close a connection or
 669 simply ignore any further requests on a connection.  Closed
 670 connections are not detected until `accept-process-output' has updated
 671 the `process-status'.  Dropped connections are not detected until the
 672 connection timeouts (which may be several minutes) or
 673 `nntp-connection-timeout' has expired.  When these occur
 674 `nntp-with-open-group', opens a new connection then re-issues the NNTP
 675 command whose response triggered the error."
 676   (declare (indent 2) (debug (form form [&optional symbolp] def-body)))
 677   (when (and (listp connectionless)
 678              (not (eq connectionless nil)))
 679     (setq forms (cons connectionless forms)
 680           connectionless nil))
 681   `(nntp-with-open-group-function ,group ,server ,connectionless (lambda () ,@forms)))
 682
 683 (deffoo nntp-retrieve-headers (articles &optional group server fetch-old)
 684   "Retrieve the headers of ARTICLES."
 685   (nntp-with-open-group
 686    group server
 687    (with-current-buffer (nntp-find-connection-buffer nntp-server-buffer)
 688      (erase-buffer)
 689      (if (and (not gnus-nov-is-evil)
 690               (not nntp-nov-is-evil)
 691               (nntp-retrieve-headers-with-xover articles fetch-old))
 692          ;; We successfully retrieved the headers via XOVER.
 693          'nov
 694        ;; XOVER didn't work, so we do it the hard, slow and inefficient
 695        ;; way.
 696        (let ((number (length articles))
 697              (articles articles)
 698              (count 0)
 699              (received 0)
 700              (last-point (point-min))
 701              (buf (nntp-find-connection-buffer nntp-server-buffer))
 702              (nntp-inhibit-erase t)
 703              article)
 704          ;; Send HEAD commands.
 705          (while (setq article (pop articles))
 706            (nntp-send-command
 707             nil
 708             "HEAD" (if (numberp article)
 709                        (int-to-string article)
 710                      ;; `articles' is either a list of article numbers
 711                      ;; or a list of article IDs.
 712                      article))
 713            (incf count)
 714            ;; Every 400 requests we have to read the stream in
 715            ;; order to avoid deadlocks.
 716            (when (or (null articles)    ;All requests have been sent.
 717                      (zerop (% count nntp-maximum-request)))
 718              (nntp-accept-response)
 719              (while (progn
 720                       (set-buffer buf)
 721                       (goto-char last-point)
 722                       ;; Count replies.
 723                       (while (nntp-next-result-arrived-p)
 724                         (setq last-point (point))
 725                         (incf received))
 726                       (< received count))
 727                ;; If number of headers is greater than 100, give
 728                ;;  informative messages.
 729                (and (numberp nntp-large-newsgroup)
 730                     (> number nntp-large-newsgroup)
 731                     (zerop (% received 20))
 732                     (nnheader-message 6 "NNTP: Receiving headers... %d%%"
 733                                       (/ (* received 100) number)))
 734                (nntp-accept-response))))
 735          (and (numberp nntp-large-newsgroup)
 736               (> number nntp-large-newsgroup)
 737               (nnheader-message 6 "NNTP: Receiving headers...done"))
 738
 739          ;; Now all of replies are received.  Fold continuation lines.
 740          (nnheader-fold-continuation-lines)
 741          ;; Remove all "\r"'s.
 742          (nnheader-strip-cr)
 743          (nntp-copy-to-buffer nntp-server-buffer (point-min) (point-max))
 744          'headers)))))
 745
 746 (deffoo nntp-retrieve-group-data-early (server infos)
 747   "Retrieve group info on INFOS."
 748   (nntp-with-open-group nil server
 749     (let ((buffer (nntp-find-connection-buffer nntp-server-buffer)))
 750       (unless infos
 751         (with-current-buffer buffer
 752           (setq nntp-retrieval-in-progress nil)))
 753       (when (and buffer
 754                  infos
 755                  (with-current-buffer buffer
 756                    (not nntp-retrieval-in-progress)))
 757         ;; The first time this is run, this variable is `try'.  So we
 758         ;; try.
 759         (when (eq nntp-server-list-active-group 'try)
 760           (nntp-try-list-active
 761            (gnus-group-real-name (gnus-info-group (car infos)))))
 762         (with-current-buffer buffer
 763           (erase-buffer)
 764           ;; Mark this buffer as "in use" in case we try to issue two
 765           ;; retrievals from the same server.  This shouldn't happen,
 766           ;; so this is mostly a sanity check.
 767           (setq nntp-retrieval-in-progress t)
 768           (let ((nntp-inhibit-erase t)
 769                 (command (if nntp-server-list-active-group
 770                              "LIST ACTIVE" "GROUP")))
 771             (dolist (info infos)
 772               (nntp-send-command
 773                nil command (gnus-group-real-name (gnus-info-group info)))))
 774           (length infos))))))
 775
 776 (deffoo nntp-finish-retrieve-group-infos (server infos count)
 777   (nntp-with-open-group nil server
 778     (let ((buf (nntp-find-connection-buffer nntp-server-buffer))
 779           (method (gnus-find-method-for-group
 780                    (gnus-info-group (car infos))
 781                    (car infos)))
 782           (received 0)
 783           (last-point 1))
 784       (with-current-buffer buf
 785         (setq nntp-retrieval-in-progress nil))
 786       (when (and buf
 787                  count)
 788         (with-current-buffer buf
 789           (while (and (gnus-buffer-live-p buf)
 790                       (progn
 791                         (goto-char last-point)
 792                         ;; Count replies.
 793                         (while (re-search-forward
 794                                 (if nntp-server-list-active-group
 795                                     "^[.]"
 796                                   "^[0-9]")
 797                                 nil t)
 798                           (incf received))
 799                         (setq last-point (point))
 800                         (< received count)))
 801             (nntp-accept-response))
 802           ;; We now have all the entries.  Remove CRs.
 803           (nnheader-strip-cr)
 804           (if (not nntp-server-list-active-group)
 805               (progn
 806                 (nntp-copy-to-buffer nntp-server-buffer
 807                                      (point-min) (point-max))
 808                 (with-current-buffer nntp-server-buffer
 809                   (gnus-groups-to-gnus-format method gnus-active-hashtb t)))
 810             ;; We have read active entries, so we just delete the
 811             ;; superfluous gunk.
 812             (goto-char (point-min))
 813             (while (re-search-forward "^[.2-5]" nil t)
 814               (delete-region (match-beginning 0)
 815                              (progn (forward-line 1) (point))))
 816             (nntp-copy-to-buffer nntp-server-buffer (point-min) (point-max))
 817             (with-current-buffer nntp-server-buffer
 818               (gnus-active-to-gnus-format
 819                ;; Kludge to use the extended method name if you have
 820                ;; an extended one.
 821                (if (consp (gnus-info-method (car infos)))
 822                    (gnus-info-method (car infos))
 823                  method)
 824                gnus-active-hashtb nil t))))))))
 825
 826 (deffoo nntp-retrieve-groups (groups &optional server)
 827   "Retrieve group info on GROUPS."
 828   (nntp-with-open-group
 829    nil server
 830    (when (and (nntp-find-connection-buffer nntp-server-buffer)
 831               (with-current-buffer
 832                   (nntp-find-connection-buffer nntp-server-buffer)
 833                 (if (not nntp-retrieval-in-progress)
 834                     t
 835                   (message "Warning: Refusing to do retrieval from %s because a retrieval is already happening"
 836                            server)
 837                   nil)))
 838      (catch 'done
 839        (save-excursion
 840          ;; Erase nntp-server-buffer before nntp-inhibit-erase.
 841          (nntp-erase-buffer nntp-server-buffer)
 842          (set-buffer (nntp-find-connection-buffer nntp-server-buffer))
 843          ;; The first time this is run, this variable is `try'.  So we
 844          ;; try.
 845          (when (eq nntp-server-list-active-group 'try)
 846            (nntp-try-list-active (car groups)))
 847          (erase-buffer)
 848          (let ((count 0)
 849                (groups groups)
 850                (received 0)
 851                (last-point (point-min))
 852                (nntp-inhibit-erase t)
 853                (buf (nntp-find-connection-buffer nntp-server-buffer))
 854                (command (if nntp-server-list-active-group
 855                             "LIST ACTIVE" "GROUP")))
 856            (while groups
 857              ;; Timeout may have killed the buffer.
 858              (unless (gnus-buffer-live-p buf)
 859                (nnheader-report 'nntp "Connection to %s is closed." server)
 860                (throw 'done nil))
 861              ;; Send the command to the server.
 862              (nntp-send-command nil command (pop groups))
 863              (incf count)
 864              ;; Every 400 requests we have to read the stream in
 865              ;; order to avoid deadlocks.
 866              (when (or (null groups)    ;All requests have been sent.
 867                        (zerop (% count nntp-maximum-request)))
 868                (nntp-accept-response)
 869                (while (and (gnus-buffer-live-p buf)
 870                            (progn
 871                              ;; Search `blue moon' in this file for the
 872                              ;; reason why set-buffer here.
 873                              (set-buffer buf)
 874                              (goto-char last-point)
 875                              ;; Count replies.
 876                              (while (re-search-forward "^[0-9]" nil t)
 877                                (incf received))
 878                              (setq last-point (point))
 879                              (< received count)))
 880                  (nntp-accept-response))))
 881
 882            ;; Wait for the reply from the final command.
 883            (unless (gnus-buffer-live-p buf)
 884              (nnheader-report 'nntp "Connection to %s is closed." server)
 885              (throw 'done nil))
 886            (set-buffer buf)
 887            (goto-char (point-max))
 888            (re-search-backward "^[0-9]" nil t)
 889            (when (looking-at "^[23]")
 890              (while (and (gnus-buffer-live-p buf)
 891                          (progn
 892                            (set-buffer buf)
 893                            (goto-char (point-max))
 894                            (if (not nntp-server-list-active-group)
 895                                (not (re-search-backward "\r?\n"
 896                                                         (- (point) 3) t))
 897                              (not (re-search-backward "^\\.\r?\n"
 898                                                       (- (point) 4) t)))))
 899                (nntp-accept-response)))
 900
 901            ;; Now all replies are received.  We remove CRs.
 902            (unless (gnus-buffer-live-p buf)
 903              (nnheader-report 'nntp "Connection to %s is closed." server)
 904              (throw 'done nil))
 905            (set-buffer buf)
 906            (goto-char (point-min))
 907            (while (search-forward "\r" nil t)
 908              (replace-match "" t t))
 909
 910            (if (not nntp-server-list-active-group)
 911                (progn
 912                  (nntp-copy-to-buffer nntp-server-buffer
 913                                       (point-min) (point-max))
 914                  'group)
 915              ;; We have read active entries, so we just delete the
 916              ;; superfluous gunk.
 917              (goto-char (point-min))
 918              (while (re-search-forward "^[.2-5]" nil t)
 919                (delete-region (match-beginning 0)
 920                               (progn (forward-line 1) (point))))
 921              (nntp-copy-to-buffer nntp-server-buffer (point-min) (point-max))
 922              'active)))))))
 923
 924 (deffoo nntp-retrieve-articles (articles &optional group server)
 925   (nntp-with-open-group
 926     group server
 927 &n