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

   1 ;;; nntp.el --- nntp access for Gnus
   2
   3 ;; Copyright (C) 1987, 1988, 1989, 1990, 1992, 1993, 1994, 1995, 1996,
   4 ;; 1997, 1998, 2000, 2001, 2002, 2003 Free Software 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
  13 ;; by the Free Software Foundation; either version 2, or (at your
  14 ;; option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful, but
  17 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19 ;; 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; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (require 'nnheader)
  30 (require 'nnoo)
  31 (require 'gnus-util)
  32
  33 (nnoo-declare nntp)
  34
  35 (eval-when-compile (require 'cl))
  36
  37 (defvoo nntp-address nil
  38   "Address of the physical nntp server.")
  39
  40 (defvoo nntp-port-number "nntp"
  41   "Port number on the physical nntp server.")
  42
  43 (defvoo nntp-server-opened-hook '(nntp-send-mode-reader)
  44   "*Hook used for sending commands to the server at startup.
  45 The default value is `nntp-send-mode-reader', which makes an innd
  46 server spawn an nnrpd server.")
  47
  48 (defvoo nntp-authinfo-function 'nntp-send-authinfo
  49   "Function used to send AUTHINFO to the server.
  50 It is called with no parameters.")
  51
  52 (defvoo nntp-server-action-alist
  53     '(("nntpd 1\\.5\\.11t"
  54        (remove-hook 'nntp-server-opened-hook 'nntp-send-mode-reader))
  55       ("NNRP server Netscape"
  56        (setq nntp-server-list-active-group nil)))
  57   "Alist of regexps to match on server types and actions to be taken.
  58 For instance, if you want Gnus to beep every time you connect
  59 to innd, you could say something like:
  60
  61 \(setq nntp-server-action-alist
  62        '((\"innd\" (ding))))
  63
  64 You probably don't want to do that, though.")
  65
  66 (defvoo nntp-open-connection-function 'nntp-open-network-stream
  67   "*Function used for connecting to a remote system.
  68 It will be called with the buffer to output in as argument.
  69
  70 Currently, five such functions are provided (please refer to their
  71 respective doc string for more information), three of them establishing
  72 direct connections to the nntp server, and two of them using an indirect
  73 host.
  74
  75 Direct connections:
  76 - `nntp-open-network-stream' (the default),
  77 - `nntp-open-ssl-stream',
  78 - `nntp-open-tls-stream',
  79 - `nntp-open-telnet-stream'.
  80
  81 Indirect connections:
  82 - `nntp-open-via-rlogin-and-telnet',
  83 - `nntp-open-via-telnet-and-telnet'.")
  84
  85 (defvoo nntp-pre-command nil
  86   "*Pre-command to use with the various nntp-open-via-* methods.
  87 This is where you would put \"runsocks\" or stuff like that.")
  88
  89 (defvoo nntp-telnet-command "telnet"
  90   "*Telnet command used to connect to the nntp server.
  91 This command is used by the various nntp-open-via-* methods.")
  92
  93 (defvoo nntp-telnet-switches '("-8")
  94   "*Switches given to the telnet command `nntp-telnet-command'.")
  95
  96 (defvoo nntp-end-of-line "\r\n"
  97   "*String to use on the end of lines when talking to the NNTP server.
  98 This is \"\\r\\n\" by default, but should be \"\\n\" when
  99 using and indirect connection method (nntp-open-via-*).")
 100
 101 (defvoo nntp-via-rlogin-command "rsh"
 102   "*Rlogin command used to connect to an intermediate host.
 103 This command is used by the `nntp-open-via-rlogin-and-telnet' method.
 104 The default is \"rsh\", but \"ssh\" is a popular alternative.")
 105
 106 (defvoo nntp-via-rlogin-command-switches nil
 107   "*Switches given to the rlogin command `nntp-via-rlogin-command'.
 108 If you use \"ssh\" for `nntp-via-rlogin-command', you may set this to
 109 \(\"-C\") in order to compress all data connections, otherwise set this
 110 to \(\"-t\" \"-e\" \"none\") or (\"-C\" \"-t\" \"-e\" \"none\") if the telnet
 111 command requires a pseudo-tty allocation on an intermediate host.")
 112
 113 (defvoo nntp-via-telnet-command "telnet"
 114   "*Telnet command used to connect to an intermediate host.
 115 This command is used by the `nntp-open-via-telnet-and-telnet' method.")
 116
 117 (defvoo nntp-via-telnet-switches '("-8")
 118   "*Switches given to the telnet command `nntp-via-telnet-command'.")
 119
 120 (defvoo nntp-via-user-name nil
 121   "*User name to log in on an intermediate host with.
 122 This variable is used by the `nntp-open-via-telnet-and-telnet' method.")
 123
 124 (defvoo nntp-via-user-password nil
 125   "*Password to use to log in on an intermediate host with.
 126 This variable is used by the `nntp-open-via-telnet-and-telnet' method.")
 127
 128 (defvoo nntp-via-address nil
 129   "*Address of an intermediate host to connect to.
 130 This variable is used by the `nntp-open-via-rlogin-and-telnet' and
 131 `nntp-open-via-telnet-and-telnet' methods.")
 132
 133 (defvoo nntp-via-envuser nil
 134   "*Whether both telnet client and server support the ENVIRON option.
 135 If non-nil, there will be no prompt for a login name.")
 136
 137 (defvoo nntp-via-shell-prompt "bash\\|\$ *\r?$\\|> *\r?"
 138   "*Regular expression to match the shell prompt on an intermediate host.
 139 This variable is used by the `nntp-open-via-telnet-and-telnet' method.")
 140
 141 (defvoo nntp-large-newsgroup 50
 142   "*The number of articles which indicates a large newsgroup.
 143 If the number of articles is greater than the value, verbose
 144 messages will be shown to indicate the current status.")
 145
 146 (defvoo nntp-maximum-request 400
 147   "*The maximum number of the requests sent to the NNTP server at one time.
 148 If Emacs hangs up while retrieving headers, set the variable to a
 149 lower value.")
 150
 151 (defvoo nntp-nov-is-evil nil
 152   "*If non-nil, nntp will never attempt to use XOVER when talking to the server.")
 153
 154 (defvoo nntp-xover-commands '("XOVER" "XOVERVIEW")
 155   "*List of strings that are used as commands to fetch NOV lines from a server.
 156 The strings are tried in turn until a positive response is gotten.  If
 157 none of the commands are successful, nntp will just grab headers one
 158 by one.")
 159
 160 (defvoo nntp-nov-gap 5
 161   "*Maximum allowed gap between two articles.
 162 If the gap between two consecutive articles is bigger than this
 163 variable, split the XOVER request into two requests.")
 164
 165 (defvoo nntp-prepare-server-hook nil
 166   "*Hook run before a server is opened.
 167 If can be used to set up a server remotely, for instance.  Say you
 168 have an account at the machine \"other.machine\".  This machine has
 169 access to an NNTP server that you can't access locally.  You could
 170 then use this hook to rsh to the remote machine and start a proxy NNTP
 171 server there that you can connect to.  See also
 172 `nntp-open-connection-function'")
 173
 174 (defvoo nntp-warn-about-losing-connection t
 175   "*If non-nil, beep when a server closes connection.")
 176
 177 (defvoo nntp-coding-system-for-read 'binary
 178   "*Coding system to read from NNTP.")
 179
 180 (defvoo nntp-coding-system-for-write 'binary
 181   "*Coding system to write to NNTP.")
 182
 183 (defcustom nntp-authinfo-file "~/.authinfo"
 184   ".netrc-like file that holds nntp authinfo passwords."
 185   :type
 186   '(choice file
 187            (repeat :tag "Entries"
 188                    :menu-tag "Inline"
 189                    (list :format "%v"
 190                          :value ("" ("login" . "") ("password" . ""))
 191                          (string :tag "Host")
 192                          (checklist :inline t
 193                                     (cons :format "%v"
 194                                           (const :format "" "login")
 195                                           (string :format "Login: %v"))
 196                                     (cons :format "%v"
 197                                           (const :format "" "password")
 198                                           (string :format "Password: %v")))))))
 199
 200 \f
 201
 202 (defvoo nntp-connection-timeout nil
 203   "*Number of seconds to wait before an nntp connection times out.
 204 If this variable is nil, which is the default, no timers are set.
 205 NOTE: This variable is never seen to work in Emacs 20 and XEmacs 21.")
 206
 207 (defvoo nntp-prepare-post-hook nil
 208   "*Hook run just before posting an article.  It is supposed to be used
 209 to insert Cancel-Lock headers.")
 210
 211 ;;; Internal variables.
 212
 213 (defvar nntp-record-commands nil
 214   "*If non-nil, nntp will record all commands in the \"*nntp-log*\" buffer.")
 215
 216 (defvar nntp-have-messaged nil)
 217
 218 (defvar nntp-process-wait-for nil)
 219 (defvar nntp-process-to-buffer nil)
 220 (defvar nntp-process-callback nil)
 221 (defvar nntp-process-decode nil)
 222 (defvar nntp-process-start-point nil)
 223 (defvar nntp-inside-change-function nil)
 224 (defvoo nntp-last-command-time nil)
 225 (defvoo nntp-last-command nil)
 226 (defvoo nntp-authinfo-password nil)
 227 (defvoo nntp-authinfo-user nil)
 228
 229 (defvar nntp-connection-list nil)
 230
 231 (defvoo nntp-server-type nil)
 232 (defvoo nntp-connection-alist nil)
 233 (defvoo nntp-status-string "")
 234 (defconst nntp-version "nntp 5.0")
 235 (defvoo nntp-inhibit-erase nil)
 236 (defvoo nntp-inhibit-output nil)
 237
 238 (defvoo nntp-server-xover 'try)
 239 (defvoo nntp-server-list-active-group 'try)
 240
 241 (defvar nntp-async-needs-kluge
 242   (string-match "^GNU Emacs 20\\.3\\." (emacs-version))
 243   "*When non-nil, nntp will poll asynchronous connections
 244 once a second.  By default, this is turned on only for Emacs
 245 20.3, which has a bug that breaks nntp's normal method of
 246 noticing asynchronous data.")
 247
 248 (defvar nntp-async-timer nil)
 249 (defvar nntp-async-process-list nil)
 250
 251 (defvar nntp-ssl-program
 252   "openssl s_client -quiet -ssl3 -connect %s:%p"
 253 "A string containing commands for SSL connections.
 254 Within a string, %s is replaced with the server address and %p with
 255 port number on server.  The program should accept IMAP commands on
 256 stdin and return responses to stdout.")
 257
 258 \f
 259
 260 ;;; Internal functions.
 261
 262 (defsubst nntp-send-string (process string)
 263   "Send STRING to PROCESS."
 264   ;; We need to store the time to provide timeouts, and
 265   ;; to store the command so the we can replay the command
 266   ;; if the server gives us an AUTHINFO challenge.
 267   (setq nntp-last-command-time (current-time)
 268         nntp-last-command string)
 269   (when nntp-record-commands
 270     (nntp-record-command string))
 271   (process-send-string process (concat string nntp-end-of-line))
 272   (or (memq (process-status process) '(open run))
 273       (nntp-report "Server closed connection")))
 274
 275 (defun nntp-record-command (string)
 276   "Record the command STRING."
 277   (save-excursion
 278     (set-buffer (get-buffer-create "*nntp-log*"))
 279     (goto-char (point-max))
 280     (let ((time (current-time)))
 281       (insert (format-time-string "%Y%m%dT%H%M%S" time)
 282               "." (format "%03d" (/ (nth 2 time) 1000))
 283               " " nntp-address " " string "\n"))))
 284
 285 (defun nntp-report (&rest args)
 286   "Report an error from the nntp backend.  The first string in ARGS
 287 can be a format string.  For some commands, the failed command may be
 288 retried once before actually displaying the error report."
 289
 290   (when nntp-record-commands
 291     (nntp-record-command "*** CALLED nntp-report ***"))
 292
 293   (nnheader-report 'nntp args)
 294
 295   (apply 'error args))
 296
 297 (defun nntp-report-1 (&rest args)
 298   "Throws out to nntp-with-open-group-error so that the connection may
 299 be restored and the command retried."
 300
 301   (when nntp-record-commands
 302     (nntp-record-command "*** CONNECTION LOST ***"))
 303
 304   (throw 'nntp-with-open-group-error t))
 305
 306 (defsubst nntp-wait-for (process wait-for buffer &optional decode discard)
 307   "Wait for WAIT-FOR to arrive from PROCESS."
 308   (save-excursion
 309     (set-buffer (process-buffer process))
 310     (goto-char (point-min))
 311     (while (and (or (not (memq (char-after (point)) '(?2 ?3 ?4 ?5)))
 312                     (looking-at "480"))
 313                 (memq (process-status process) '(open run)))
 314       (when (looking-at "480")
 315         (nntp-handle-authinfo process))
 316       (when (looking-at "^.*\n")
 317         (delete-region (point) (progn (forward-line 1) (point))))
 318       (nntp-accept-process-output process)
 319       (goto-char (point-min)))
 320     (prog1
 321         (cond
 322          ((looking-at "[45]")
 323           (progn
 324             (nntp-snarf-error-message)
 325             nil))
 326          ((not (memq (process-status process) '(open run)))
 327           (nntp-report "Server closed connection"))
 328          (t
 329           (goto-char (point-max))
 330           (let ((limit (point-min))
 331                 response)
 332             (while (not (re-search-backward wait-for limit t))
 333               (nntp-accept-process-output process)
 334               ;; We assume that whatever we wait for is less than 1000
 335               ;; characters long.
 336               (setq limit (max (- (point-max) 1000) (point-min)))
 337               (goto-char (point-max)))
 338             (setq response (match-string 0))
 339             (with-current-buffer nntp-server-buffer
 340               (setq nntp-process-response response)))
 341           (nntp-decode-text (not decode))
 342           (unless discard
 343             (save-excursion
 344               (set-buffer buffer)
 345               (goto-char (point-max))
 346               (insert-buffer-substring (process-buffer process))
 347               ;; Nix out "nntp reading...." message.
 348               (when nntp-have-messaged
 349                 (setq nntp-have-messaged nil)
 350                 (nnheader-message 5 ""))))
 351           t))
 352       (unless discard
 353         (erase-buffer)))))
 354
 355 (defun nntp-kill-buffer (buffer)
 356   (when (buffer-name buffer)
 357     (kill-buffer buffer)
 358     (nnheader-init-server-buffer)))
 359
 360 (defsubst nntp-find-connection (buffer)
 361   "Find the connection delivering to BUFFER."
 362   (let ((alist nntp-connection-alist)
 363         (buffer (if (stringp buffer) (get-buffer buffer) buffer))
 364         process entry)
 365     (while (and alist (setq entry (pop alist)))
 366       (when (eq buffer (cadr entry))
 367         (setq process (car entry)
 368               alist nil)))
 369     (when process
 370       (if (memq (process-status process) '(open run))
 371           process
 372         (nntp-kill-buffer (process-buffer process))
 373         (setq nntp-connection-alist (delq entry nntp-connection-alist))
 374         nil))))
 375
 376 (defsubst nntp-find-connection-entry (buffer)
 377   "Return the entry for the connection to BUFFER."
 378   (assq (nntp-find-connection buffer) nntp-connection-alist))
 379
 380 (defun nntp-find-connection-buffer (buffer)
 381   "Return the process connection buffer tied to BUFFER."
 382   (let ((process (nntp-find-connection buffer)))
 383     (when process
 384       (process-buffer process))))
 385
 386 (defsubst nntp-retrieve-data (command address port buffer
 387                                       &optional wait-for callback decode)
 388   "Use COMMAND to retrieve data into BUFFER from PORT on ADDRESS."
 389   (let ((process (or (nntp-find-connection buffer)
 390                      (nntp-open-connection buffer))))
 391     (if process
 392         (progn
 393           (unless (or nntp-inhibit-erase nnheader-callback-function)
 394             (save-excursion
 395               (set-buffer (process-buffer process))
 396               (erase-buffer)))
 397           (condition-case err
 398               (progn
 399                 (when command
 400                   (nntp-send-string process command))
 401                 (cond
 402                  ((eq callback 'ignore)
 403                   t)
 404                  ((and callback wait-for)
 405                   (nntp-async-wait process wait-for buffer decode callback)
 406                   t)
 407                  (wait-for
 408                   (nntp-wait-for process wait-for buffer decode))
 409                  (t t)))
 410             (error
 411              (nnheader-report 'nntp "Couldn't open connection to %s: %s"
 412                               address err))
 413             (quit
 414              (message "Quit retrieving data from nntp")
 415              (signal 'quit nil)
 416              nil)))
 417       (nnheader-report 'nntp "Couldn't open connection to %s" address))))
 418
 419 (defsubst nntp-send-command (wait-for &rest strings)
 420   "Send STRINGS to server and wait until WAIT-FOR returns."
 421   (when (and (not nnheader-callback-function)
 422              (not nntp-inhibit-output))
 423     (save-excursion
 424       (set-buffer nntp-server-buffer)
 425       (erase-buffer)))
 426   (let* ((command (mapconcat 'identity strings " "))
 427          (process (nntp-find-connection nntp-server-buffer))
 428          (buffer (and process (process-buffer process)))
 429          (pos (and buffer (with-current-buffer buffer (point)))))
 430     (if process
 431         (prog1
 432             (nntp-retrieve-data command
 433                                 nntp-address nntp-port-number
 434                                 nntp-server-buffer
 435                                 wait-for nnheader-callback-function)
 436           ;; If nothing to wait for, still remove possibly echo'ed commands.
 437           ;; We don't have echos if nntp-open-connection-function
 438           ;; is `nntp-open-network-stream', so we skip this in that case.
 439           (unless (or wait-for
 440                       (equal nntp-open-connection-function
 441                              'nntp-open-network-stream))
 442             (nntp-accept-response)
 443             (save-excursion
 444               (set-buffer buffer)
 445               (goto-char pos)
 446               (if (looking-at (regexp-quote command))
 447                   (delete-region pos (progn (forward-line 1)
 448                                             (point-at-bol))))
 449               )))
 450       (nnheader-report 'nntp "Couldn't open connection to %s."
 451                        nntp-address))))
 452
 453 (defun nntp-send-command-nodelete (wait-for &rest strings)
 454   "Send STRINGS to server and wait until WAIT-FOR returns."
 455   (let* ((command (mapconcat 'identity strings " "))
 456          (process (nntp-find-connection nntp-server-buffer))
 457          (buffer (and process (process-buffer process)))
 458          (pos (and buffer (with-current-buffer buffer (point)))))
 459     (if process
 460         (prog1
 461             (nntp-retrieve-data command
 462                                 nntp-address nntp-port-number
 463                                 nntp-server-buffer
 464                                 wait-for nnheader-callback-function)
 465           ;; If nothing to wait for, still remove possibly echo'ed commands
 466           (unless wait-for
 467             (nntp-accept-response)
 468             (save-excursion
 469               (set-buffer buffer)
 470               (goto-char pos)
 471               (if (looking-at (regexp-quote command))
 472                   (delete-region pos (progn (forward-line 1)
 473                                             (point-at-bol)))))))
 474       (nnheader-report 'nntp "Couldn't open connection to %s."
 475                        nntp-address))))
 476
 477 (defun nntp-send-command-and-decode (wait-for &rest strings)
 478   "Send STRINGS to server and wait until WAIT-FOR returns."
 479   (when (and (not nnheader-callback-function)
 480              (not nntp-inhibit-output))
 481     (save-excursion
 482       (set-buffer nntp-server-buffer)
 483       (erase-buffer)))
 484   (let* ((command (mapconcat 'identity strings " "))
 485          (process (nntp-find-connection nntp-server-buffer))
 486          (buffer (and process (process-buffer process)))
 487          (pos (and buffer (with-current-buffer buffer (point)))))
 488     (if process
 489         (prog1
 490             (nntp-retrieve-data command
 491                                 nntp-address nntp-port-number
 492                                 nntp-server-buffer
 493                                 wait-for nnheader-callback-function t)
 494           ;; If nothing to wait for, still remove possibly echo'ed commands
 495           (unless wait-for
 496             (nntp-accept-response)
 497             (save-excursion
 498           (set-buffer buffer)
 499           (goto-char pos)
 500           (if (looking-at (regexp-quote command))
 501               (delete-region pos (progn (forward-line 1) (point-at-bol))))
 502           )))
 503       (nnheader-report 'nntp "Couldn't open connection to %s."
 504                        nntp-address))))
 505
 506
 507 (defun nntp-send-buffer (wait-for)
 508   "Send the current buffer to server and wait until WAIT-FOR returns."
 509   (when (and (not nnheader-callback-function)
 510              (not nntp-inhibit-output))
 511     (save-excursion
 512       (set-buffer (nntp-find-connection-buffer nntp-server-buffer))
 513       (erase-buffer)))
 514   (nntp-encode-text)
 515   (mm-with-unibyte-current-buffer
 516     ;; Some encoded unicode text contains character 0x80-0x9f e.g. Euro.
 517     (process-send-region (nntp-find-connection nntp-server-buffer)
 518                          (point-min) (point-max)))
 519   (nntp-retrieve-data
 520    nil nntp-address nntp-port-number nntp-server-buffer
 521    wait-for nnheader-callback-function))
 522
 523 \f
 524
 525 ;;; Interface functions.
 526
 527 (nnoo-define-basics nntp)
 528
 529 (defsubst nntp-next-result-arrived-p ()
 530   (cond
 531    ;; A result that starts with a 2xx code is terminated by
 532    ;; a line with only a "." on it.
 533    ((eq (char-after) ?2)
 534     (if (re-search-forward "\n\\.\r?\n" nil t)
 535         t
 536       nil))
 537    ;; A result that starts with a 3xx or 4xx code is terminated
 538    ;; by a newline.
 539    ((looking-at "[34]")
 540     (if (search-forward "\n" nil t)
 541         t
 542       nil))
 543    ;; No result here.
 544    (t
 545     nil)))
 546
 547 (eval-when-compile
 548   (defvar nntp-with-open-group-internal nil)
 549   (defvar nntp-report-n nil))
 550
 551 (defmacro nntp-with-open-group (group server &optional connectionless &rest forms)
 552   "Protect against servers that don't like clients that keep idle connections opens.
 553 The problem being that these servers may either close a connection or
 554 simply ignore any further requests on a connection.  Closed
 555 connections are not detected until accept-process-output has updated
 556 the process-status.  Dropped connections are not detected until the
 557 connection timeouts (which may be several minutes) or
 558 nntp-connection-timeout has expired.  When these occur
 559 nntp-with-open-group, opens a new connection then re-issues the NNTP
 560 command whose response triggered the error."
 561   (when (and (listp connectionless)
 562              (not (eq connectionless nil)))
 563     (setq forms (cons connectionless forms)
 564           connectionless nil))
 565   `(letf ((nntp-report-n (symbol-function 'nntp-report))
 566           ((symbol-function 'nntp-report) (symbol-function 'nntp-report-1))
 567           (nntp-with-open-group-internal nil))
 568      (while (catch 'nntp-with-open-group-error
 569               ;; Open the connection to the server
 570               ;; NOTE: Existing connections are NOT tested.
 571               (nntp-possibly-change-group ,group ,server ,connectionless)
 572
 573               (let ((timer
 574                      (and nntp-connection-timeout
 575                           (nnheader-run-at-time
 576                            nntp-connection-timeout nil
 577                            '(lambda ()
 578                               (let ((process (nntp-find-connection
 579                                               nntp-server-buffer))
 580                                     (buffer  (and process
 581                                                   (process-buffer process))))
 582                                 ;; When I an able to identify the
 583                                 ;; connection to the server AND I've
 584                                 ;; received NO reponse for
 585                                 ;; nntp-connection-timeout seconds.
 586                                 (when (and buffer (eq 0 (buffer-size buffer)))
 587                                   ;; Close the connection.  Take no
 588                                   ;; other action as the accept input
 589                                   ;; code will handle the closed
 590                                   ;; connection.
 591                                   (nntp-kill-buffer buffer))))))))
 592                 (unwind-protect
 593                     (setq nntp-with-open-group-internal
 594                           (condition-case nil
 595                               (progn ,@forms)
 596                             (quit
 597                              (nntp-close-server)
 598                              (signal 'quit nil))))
 599                   (when timer
 600                     (nnheader-cancel-timer timer)))
 601                 nil))
 602        (setf (symbol-function 'nntp-report) nntp-report-n))
 603      nntp-with-open-group-internal))
 604
 605 (deffoo nntp-retrieve-headers (articles &optional group server fetch-old)
 606   "Retrieve the headers of ARTICLES."
 607   (nntp-with-open-group
 608    group server
 609    (save-excursion
 610      (set-buffer (nntp-find-connection-buffer nntp-server-buffer))
 611      (erase-buffer)
 612      (if (and (not gnus-nov-is-evil)
 613               (not nntp-nov-is-evil)
 614               (nntp-retrieve-headers-with-xover articles fetch-old))
 615          ;; We successfully retrieved the headers via XOVER.
 616          'nov
 617        ;; XOVER didn't work, so we do it the hard, slow and inefficient
 618        ;; way.
 619        (let ((number (length articles))
 620              (articles articles)
 621              (count 0)
 622              (received 0)
 623              (last-point (point-min))
 624              (buf (nntp-find-connection-buffer nntp-server-buffer))
 625              (nntp-inhibit-erase t)
 626              article)
 627          ;; Send HEAD commands.
 628          (while (setq article (pop articles))
 629            (nntp-send-command
 630             nil
 631             "HEAD" (if (numberp article)
 632                        (int-to-string article)
 633                      ;; `articles' is either a list of article numbers
 634                      ;; or a list of article IDs.
 635                      article))
 636            (incf count)
 637            ;; Every 400 requests we have to read the stream in
 638            ;; order to avoid deadlocks.
 639            (when (or (null articles)    ;All requests have been sent.
 640                      (zerop (% count nntp-maximum-request)))
 641              (nntp-accept-response)
 642              (while (progn
 643                       (set-buffer buf)
 644                       (goto-char last-point)
 645                       ;; Count replies.
 646                       (while (nntp-next-result-arrived-p)
 647                         (setq last-point (point))
 648                         (incf received))
 649                       (< received count))
 650                ;; If number of headers is greater than 100, give
 651                ;;  informative messages.
 652                (and (numberp nntp-large-newsgroup)
 653                     (> number nntp-large-newsgroup)
 654                     (zerop (% received 20))
 655                     (nnheader-message 6 "NNTP: Receiving headers... %d%%"
 656                                       (/ (* received 100) number)))
 657                (nntp-accept-response))))
 658          (and (numberp nntp-large-newsgroup)
 659               (> number nntp-large-newsgroup)
 660               (nnheader-message 6 "NNTP: Receiving headers...done"))
 661
 662          ;; Now all of replies are received.  Fold continuation lines.
 663          (nnheader-fold-continuation-lines)
 664          ;; Remove all "\r"'s.
 665          (nnheader-strip-cr)
 666          (copy-to-buffer nntp-server-buffer (point-min) (point-max))
 667          'headers)))))
 668
 669 (deffoo nntp-retrieve-groups (groups &optional server)
 670   "Retrieve group info on GROUPS."
 671   (nntp-with-open-group
 672    nil server
 673    (when (nntp-find-connection-buffer nntp-server-buffer)
 674      (catch 'done
 675        (save-excursion
 676          ;; Erase nntp-server-buffer before nntp-inhibit-erase.
 677          (set-buffer nntp-server-buffer)
 678          (erase-buffer)
 679          (set-buffer (nntp-find-connection-buffer nntp-server-buffer))
 680          ;; The first time this is run, this variable is `try'.  So we
 681          ;; try.
 682          (when (eq nntp-server-list-active-group 'try)
 683            (nntp-try-list-active (car groups)))
 684          (erase-buffer)
 685          (let ((count 0)
 686                (groups groups)
 687                (received 0)
 688                (last-point (point-min))
 689                (nntp-inhibit-erase t)
 690                (buf (nntp-find-connection-buffer nntp-server-buffer))
 691                (command (if nntp-server-list-active-group
 692                             "LIST ACTIVE" "GROUP")))
 693            (while groups
 694              ;; Timeout may have killed the buffer.
 695              (unless (gnus-buffer-live-p buf)
 696                (nnheader-report 'nntp "Connection to %s is closed." server)
 697                (throw 'done nil))
 698              ;; Send the command to the server.
 699              (nntp-send-command nil command (pop groups))
 700              (incf count)
 701              ;; Every 400 requests we have to read the stream in
 702              ;; order to avoid deadlocks.
 703              (when (or (null groups)    ;All requests have been sent.
 704                        (zerop (% count nntp-maximum-request)))
 705                (nntp-accept-response)
 706                (while (and (gnus-buffer-live-p buf)
 707                            (progn
 708                              ;; Search `blue moon' in this file for the
 709                              ;; reason why set-buffer here.
 710                              (set-buffer buf)
 711                              (goto-char last-point)
 712                              ;; Count replies.
 713                              (while (re-search-forward "^[0-9]" nil t)
 714                                (incf received))
 715                              (setq last-point (point))
 716                              (< received count)))
 717                  (nntp-accept-response))))
 718
 719            ;; Wait for the reply from the final command.
 720            (unless (gnus-buffer-live-p buf)
 721              (nnheader-report 'nntp "Connection to %s is closed." server)
 722              (throw 'done nil))
 723            (set-buffer buf)
 724            (goto-char (point-max))
 725            (re-search-backward "^[0-9]" nil t)
 726            (when (looking-at "^[23]")
 727              (while (and (gnus-buffer-live-p buf)
 728                          (progn
 729                            (set-buffer buf)
 730                            (goto-char (point-max))
 731                            (if (not nntp-server-list-active-group)
 732                                (not (re-search-backward "\r?\n"
 733                                                         (- (point) 3) t))
 734                              (not (re-search-backward "^\\.\r?\n"
 735                                                       (- (point) 4) t)))))
 736                (nntp-accept-response)))
 737
 738            ;; Now all replies are received.  We remove CRs.
 739            (unless (gnus-buffer-live-p buf)
 740              (nnheader-report 'nntp "Connection to %s is closed." server)
 741              (throw 'done nil))
 742            (set-buffer buf)
 743            (goto-char (point-min))
 744            (while (search-forward "\r" nil t)
 745              (replace-match "" t t))
 746
 747            (if (not nntp-server-list-active-group)
 748                (progn
 749                  (copy-to-buffer nntp-server-buffer (point-min) (point-max))
 750                  'group)
 751              ;; We have read active entries, so we just delete the
 752              ;; superfluous gunk.
 753              (goto-char (point-min))
 754              (while (re-search-forward "^[.2-5]" nil t)
 755                (delete-region (match-beginning 0)
 756                               (progn (forward-line 1) (point))))
 757              (copy-to-buffer nntp-server-buffer (point-min) (point-max))
 758              'active)))))))
 759
 760 (deffoo nntp-retrieve-articles (articles &optional group server)
 761   (nntp-with-open-group
 762     group server
 763    (save-excursion
 764      (let ((number (length articles))
 765            (articles articles)
 766            (count 0)
 767            (received 0)
 768            (last-point (point-min))
 769            (buf (nntp-find-connection-buffer nntp-server-buffer))
 770            (nntp-inhibit-erase t)
 771            (map (apply 'vector articles))
 772            (point 1)
 773            article)
 774        (set-buffer buf)
 775        (erase-buffer)
 776        ;; Send ARTICLE command.
 777        (while (setq article (pop articles))
 778          (nntp-send-command
 779           nil
 780           "ARTICLE" (if (numberp article)
 781                         (int-to-string article)
 782                       ;; `articles' is either a list of article numbers
 783                       ;; or a list of article IDs.
 784                       article))
 785          (incf count)
 786          ;; Every 400 requests we have to read the stream in
 787          ;; order to avoid deadlocks.
 788          (when (or (null articles)      ;All requests have been sent.
 789                    (zerop (% count nntp-maximum-request)))
 790            (nntp-accept-response)
 791            (while (progn
 792                     (set-buffer buf)
 793                     (goto-char last-point)
 794                     ;; Count replies.
 795                     (while (nntp-next-result-arrived-p)
 796                       (aset map received (cons (aref map received) (point)))
 797                       (setq last-point (point))
 798                       (incf received))
 799                     (< received count))
 800              ;; If number of headers is greater than 100, give
 801              ;;  informative messages.
 802              (and (numberp nntp-large-newsgroup)
 803                   (> number nntp-large-newsgroup)
 804                   (zerop (% received 20))
 805                   (nnheader-message 6 "NNTP: Receiving articles... %d%%"
 806                                     (/ (* received 100) number)))
 807              (nntp-accept-response))))
 808        (and (numberp nntp-large-newsgroup)
 809             (> number nntp-large-newsgroup)
 810             (nnheader-message 6 "NNTP: Receiving articles...done"))
 811
 812        ;; Now we have all the responses.  We go through the results,
 813        ;; wash it and copy it over to the server buffer.
 814        (set-buffer nntp-server-buffer)
 815        (erase-buffer)
 816        (setq last-point (point-min))
 817        (mapcar
 818         (lambda (entry)
 819           (narrow-to-region
 820            (setq point (goto-char (point-max)))
 821            (progn
 822              (insert-buffer-substring buf last-point (cdr entry))
 823              (point-max)))
 824           (setq last-point (cdr entry))
 825           (nntp-decode-text)
 826           (widen)
 827           (cons (car entry) point))
 828         map)))))
 829
 830 (defun nntp-try-list-active (group)
 831   (nntp-list-active-group group)
 832   (save-excursion
 833     (set-buffer nntp-server-buffer)
 834     (goto-char (point-min))
 835     (cond ((or (eobp)
 836                (looking-at "5[0-9]+"))
 837            (setq nntp-server-list-active-group nil))
 838           (t
 839            (setq nntp-server-list-active-group t)))))
 840
 841 (deffoo nntp-list-active-group (group &optional server)
 842   "Return the active info on GROUP (which can be a regexp)."
 843   (nntp-with-open-group
 844    nil server
 845    (nntp-send-command "^\\.*\r?\n" "LIST ACTIVE" group)))
 846
 847 (deffoo nntp-request-group-articles (group &optional server)
 848   "Return the list of existing articles in GROUP."
 849   (nntp-with-open-group
 850    nil server
 851    (nntp-send-command "^\\.*\r?\n" "LISTGROUP" group)))
 852
 853 (deffoo nntp-request-article (article &optional group server buffer command)
 854   (nntp-with-open-group
 855     group server
 856     (when (nntp-send-command-and-decode
 857            "\r?\n\\.\r?\n" "ARTICLE"
 858            (if (numberp article) (int-to-string article) article))
 859       (if (and buffer
 860                (not (equal buffer nntp-server-buffer)))
 861           (save-excursion
 862             (set-buffer nntp-server-buffer)
 863             (copy-to-buffer buffer (point-min) (point-max))
 864             (nntp-find-group-and-number group))
 865         (nntp-find-group-and-number group)))))
 866
 867 (deffoo nntp-request-head (article &optional group server)
 868   (nntp-with-open-group
 869    group server
 870    (when (nntp-send-command
 871           "\r?\n\\.\r?\n" "HEAD"
 872           (if (numberp article) (int-to-string article) article))
 873      (prog1
 874          (nntp-find-group-and-number group)
 875        (nntp-decode-text)))))
 876
 877 (deffoo nntp-request-body (article &optional group server)
 878   (nntp-with-open-group
 879    group server
 880    (nntp-send-command-and-decode
 881     "\r?\n\\.\r?\n" "BODY"
 882     (if (numberp article) (int-to-string article) article))))
 883
 884 (deffoo nntp-request-group (group &optional server dont-check)
 885   (nntp-with-open-group
 886     nil server
 887     (when (nntp-send-command "^[245].*\n" "GROUP" group)
 888       (let ((entry (nntp-find-connection-entry nntp-server-buffer)))
 889         (setcar (cddr entry) group)))))
 890
 891 (deffoo nntp-close-group (group &optional server)
 892   t)
 893
 894 (deffoo nntp-server-opened (&optional server)
 895   "Say whether a connection to SERVER has been opened."
 896   (and (nnoo-current-server-p 'nntp server)
 897        nntp-server-buffer
 898        (gnus-buffer-live-p nntp-server-buffer)
 899        (nntp-find-connection nntp-server-buffer)))
 900
 901 (deffoo nntp-open-server (server &optional defs connectionless)
 902   (nnheader-init-server-buffer)
 903   (if (nntp-server-opened server)
 904       t
 905     (when (or (stringp (car defs))
 906               (numberp (car defs)))
 907       (setq defs (cons (list 'nntp-port-number (car defs)) (cdr defs))))
 908     (unless (assq 'nntp-address defs)
 909       (setq defs (append defs (list (list 'nntp-address server)))))
 910     (nnoo-change-server 'nntp server defs)
 911     (unless connectionless
 912       (or (nntp-find-connection nntp-server-buffer)
 913           (nntp-open-connection nntp-server-buffer)))))
 914
 915 (deffoo nntp-close-server (&optional server)
 916   (nntp-possibly-change-group nil server t)
 917   (let ((process (nntp-find-connection nntp-server-buffer)))
 918     (while process
 919       (when (memq (process-status process) '(open run))
 920         (ignore-errors
 921           (nntp-send-string process "QUIT")
 922           (unless (eq nntp-open-connection-function 'nntp-open-network-stream)
 923             ;; Ok, this is evil, but when using telnet and stuff
 924             ;; as the connection method, it's important that the
 925             ;; QUIT command actually is sent out before we kill
 926             ;; the process.
 927             (sleep-for 1))))
 928       (nntp-kill-buffer (process-buffer process))
 929       (setq process (car (pop nntp-connection-alist))))
 930     (nnoo-close-server 'nntp)))
 931
 932 (deffoo nntp-request-close ()
 933   (let (process)
 934     (while (setq process (pop nntp-connection-list))
 935       (when (memq (process-status process) '(open run))
 936         (ignore-errors
 937           (nntp-send-string process "QUIT")
 938           (unless (eq nntp-open-connection-function 'nntp-open-network-stream)
 939             ;; Ok, this is evil, but when using telnet and stuff
 940             ;; as the connection method, it's important that the
 941             ;; QUIT command actually is sent out before we kill
 942             ;; the process.
 943             (sleep-for 1))))
 944       (nntp-kill-buffer (process-buffer process)))))
 945
 946 (deffoo nntp-request-list (&optional server)
 947   (nntp-with-open-group
 948    nil server
 949    (nntp-send-command-and-decode "\r?\n\\.\r?\n" "LIST")))
 950
 951 (deffoo nntp-request-list-newsgroups (&optional server)
 952   (nntp-with-open-group
 953    nil server
 954    (nntp-send-command "\r?\n\\.\r?\n" "LIST NEWSGROUPS")))
 955
 956 (deffoo nntp-request-newgroups (date &optional server)
 957   (nntp-with-open-group
 958    nil server
 959    (save-excursion
 960      (set-buffer nntp-server-buffer)
 961      (let* ((time (date-to-time date))
 962             (ls (- (cadr time) (nth 8 (decode-time time)))))
 963        (cond ((< ls 0)
 964               (setcar time (1- (car time)))
 965               (setcar (cdr time) (+ ls 65536)))
 966              ((>= ls 65536)
 967               (setcar time (1+ (car time)))
 968               (setcar (cdr time) (- ls 65536)))
 969              (t
 970               (setcar (cdr time) ls)))
 971        (prog1
 972            (nntp-send-command
 973             "^\\.\r?\n" "NEWGROUPS"
 974             (format-time-string "%y%m%d %H%M%S" time)
 975             "GMT")
 976          (nntp-decode-text))))))
 977
 978 (deffoo nntp-request-post (&optional server)
 979   (nntp-with-open-group
 980    nil server
 981    (when (nntp-send-command "^[23].*\r?\n" "POST")
 982      (let ((response (with-current-buffer nntp-server-buffer
 983                        nntp-process-response))
 984            server-id)
 985        (when (and response
 986                   (string-match "^[23].*\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)"
 987                                 response))
 988          (setq server-id (match-string 1 response))
 989          (narrow-to-region (goto-char (point-min))
 990                            (if (search-forward "\n\n" nil t)
 991                                (1- (point))
 992                              (point-max)))
 993          (unless (mail-fetch-field "Message-ID")
 994            (goto-char (point-min))
 995            (insert "Message-ID: " server-id "\n"))
 996          (widen))
 997        (run-hooks 'nntp-prepare-post-hook)
 998        (nntp-send-buffer "^[23].*\n")))))
 999
1000 (deffoo nntp-request-type (group article)
1001   'news)
1002
1003 (deffoo nntp-asynchronous-p ()
1004   t)
1005
1006 ;;; Hooky functions.
1007
1008 (defun nntp-send-mode-reader ()
1009   "Send the MODE READER command to the nntp server.
1010 This function is supposed to be called from `nntp-server-opened-hook'.
1011 It will make innd servers spawn an nnrpd process to allow actual article
1012 reading."
1013   (nntp-send-command "^.*\n" "MODE READER"))
1014
1015 (defun nntp-send-authinfo (&optional send-if-force)
1016   "Send the AUTHINFO to the nntp server.
1017 It will look in the \"~/.authinfo\" file for matching entries.  If
1018 nothing suitable is found there, it will prompt for a user name
1019 and a password.
1020
1021 If SEND-IF-FORCE, only send authinfo to the server if the
1022 .authinfo file has the FORCE token."
1023   (let* ((list (gnus-parse-netrc nntp-authinfo-file))
1024          (alist (gnus-netrc-machine list nntp-address "nntp"))
1025          (force (gnus-netrc-get alist "force"))
1026          (user (or (gnus-netrc-get alist "login") nntp-authinfo-user))
1027          (passwd (gnus-netrc-get alist "password")))
1028     (when (or (not send-if-force)
1029               force)
1030       (unless user
1031         (setq user (read-string (format "NNTP (%s) user name: " nntp-address))
1032               nntp-authinfo-user user))
1033       (unless (member user '(nil ""))
1034         (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" user)
1035         (when t                         ;???Should check if AUTHINFO succeeded
1036           (nntp-send-command
1037            "^2.*\r?\n" "AUTHINFO PASS"
1038            (or passwd
1039                nntp-authinfo-password
1040                (setq nntp-authinfo-password
1041                      (read-passwd (format "NNTP (%s@%s) password: "
1042                                           user nntp-address))))))))))
1043
1044 (defun nntp-send-nosy-authinfo ()
1045   "Send the AUTHINFO to the nntp server."
1046   (let ((user (read-string (format "NNTP (%s) user name: " nntp-address))))
1047     (unless (member user '(nil ""))
1048       (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" user)
1049       (when t                           ;???Should check if AUTHINFO succeeded
1050         (nntp-send-command "^2.*\r?\n" "AUTHINFO PASS"
1051                            (read-passwd (format "NNTP (%s@%s) password: "
1052                                                 user nntp-address)))))))
1053
1054 (defun nntp-send-authinfo-from-file ()
1055   "Send the AUTHINFO to the nntp server.
1056
1057 The authinfo login name is taken from the user's login name and the
1058 password contained in '~/.nntp-authinfo'."
1059   (when (file-exists-p "~/.nntp-authinfo")
1060     (with-temp-buffer
1061       (insert-file-contents "~/.nntp-authinfo")
1062       (goto-char (point-min))
1063       (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" (user-login-name))
1064       (nntp-send-command
1065        "^2.*\r?\n" "AUTHINFO PASS"
1066        (buffer-substring (point) (point-at-eol))))))
1067
1068 ;;; Internal functions.
1069
1070 (defun nntp-handle-authinfo (process)
1071   "Take care of an authinfo response from the server."
1072   (let ((last nntp-last-command))
1073     (funcall nntp-authinfo-function)
1074     ;; We have to re-send the function that was interrupted by
1075     ;; the authinfo request.
1076     (save-excursion
1077       (set-buffer nntp-server-buffer)
1078       (erase-buffer))
1079     (nntp-send-string process last)))
1080
1081 (defun nntp-make-process-buffer (buffer)
1082   "Create a new, fresh buffer usable for nntp process connections."
1083   (save-excursion
1084     (set-buffer
1085      (generate-new-buffer
1086       (format " *server %s %s %s*"
1087               nntp-address nntp-port-number
1088               (gnus-buffer-exists-p buffer))))
1089     (mm-enable-multibyte)
1090     (set (make-local-variable 'after-change-functions) nil)
1091     (set (make-local-variable 'nntp-process-wait-for) nil)
1092     (set (make-local-variable 'nntp-process-callback) nil)
1093     (set (make-local-variable 'nntp-process-to-buffer) nil)
1094     (set (make-local-variable 'nntp-process-start-point) nil)
1095     (set (make-local-variable 'nntp-process-decode) nil)
1096     (current-buffer)))
1097
1098 (defun nntp-open-connection (buffer)
1099   "Open a connection to PORT on ADDRESS delivering output to BUFFER."
1100   (run-hooks 'nntp-prepare-server-hook)
1101   (let* ((pbuffer (nntp-make-process-buffer buffer))
1102          (timer
1103           (and nntp-connection-timeout
1104                (nnheader-run-at-time
1105                 nntp-connection-timeout nil
1106                 `(lambda ()
1107                    (nntp-kill-buffer ,pbuffer)))))
1108          (process
1109           (condition-case ()
1110               (let ((coding-system-for-read nntp-coding-system-for-read)
1111                     (coding-system-for-write nntp-coding-system-for-write))
1112                 (funcall nntp-open-connection-function pbuffer))
1113             (error nil)
1114             (quit
1115              (message "Quit opening connection")
1116              (nntp-kill-buffer pbuffer)
1117              (signal 'quit nil)
1118              nil))))
1119     (when timer
1120       (nnheader-cancel-timer timer))
1121     (unless process
1122       (nntp-kill-buffer pbuffer))
1123     (when (and (buffer-name pbuffer)
1124                process)
1125       (process-kill-without-query process)
1126       (if (and (nntp-wait-for process "^2.*\n" buffer nil t)
1127                (memq (process-status process) '(open run)))
1128           (prog1
1129               (caar (push (list process buffer nil) nntp-connection-alist))
1130             (push process nntp-connection-list)
1131             (save-excursion
1132               (set-buffer pbuffer)
1133               (nntp-read-server-type)
1134               (erase-buffer)
1135               (set-buffer nntp-server-buffer)
1136               (let ((nnheader-callback-function nil))
1137                 (run-hooks 'nntp-server-opened-hook)
1138                 (nntp-send-authinfo t))))
1139         (nntp-kill-buffer (process-buffer process))
1140         nil))))
1141
1142 (defun nntp-open-network-stream (buffer)
1143   (open-network-stream "nntpd" buffer nntp-address nntp-port-number))
1144
1145 (autoload 'format-spec "format")
1146 (autoload 'format-spec-make "format")
1147 (autoload 'open-tls-stream "tls")
1148
1149 (defun nntp-open-ssl-stream (buffer)
1150   (let* ((process-connection-type nil)
1151          (proc (start-process "nntpd" buffer
1152                               shell-file-name
1153                               shell-command-switch
1154                               (format-spec nntp-ssl-program
1155                                            (format-spec-make
1156                                             ?s nntp-address
1157                                             ?p nntp-port-number)))))
1158     (process-kill-without-query proc)
1159     (save-excursion
1160       (set-buffer buffer)
1161       (let ((nntp-connection-alist (list proc buffer nil)))
1162         (nntp-wait-for-string "^\r*20[01]"))
1163       (beginning-of-line)
1164       (delete-region (point-min) (point))
1165       proc)))
1166
1167 (defun nntp-open-tls-stream (buffer)
1168   (let ((proc (open-tls-stream "nntpd" buffer nntp-address nntp-port-number)))
1169     (process-kill-without-query proc)
1170     (save-excursion
1171       (set-buffer buffer)
1172       (let ((nntp-connection-alist (list proc buffer nil)))
1173         (nntp-wait-for-string "^\r*20[01]"))
1174       (beginning-of-line)
1175       (delete-region (point-min) (point))
1176       proc)))
1177
1178 (defun nntp-read-server-type ()
1179   "Find out what the name of the server we have connected to is."
1180   ;; Wait for the status string to arrive.
1181   (setq nntp-server-type (buffer-string))
1182   (let ((alist nntp-server-action-alist)
1183         (case-fold-search t)
1184         entry)
1185     ;; Run server-specific commands.
1186     (while alist
1187       (setq entry (pop alist))
1188       (when (string-match (car entry) nntp-server-type)
1189         (if (and (listp (cadr entry))
1190                  (not (eq 'lambda (caadr entry))))
1191             (eval (cadr entry))
1192           (funcall (cadr entry)))))))
1193
1194 (defun nntp-async-wait (process wait-for buffer decode callback)
1195   (save-excursion
1196     (set-buffer (process-buffer process))
1197     (unless nntp-inside-change-function
1198       (erase-buffer))
1199     (setq nntp-process-wait-for wait-for
1200           nntp-process-to-buffer buffer
1201           nntp-process-decode decode
1202           nntp-process-callback callback
1203           nntp-process-start-point (point-max))
1204     (setq after-change-functions '(nntp-after-change-function))
1205     (if nntp-async-needs-kluge
1206         (nntp-async-kluge process))))
1207
1208 (defun nntp-async-kluge (process)
1209   ;; emacs 20.3 bug: process output with encoding 'binary
1210   ;; doesn't trigger after-change-functions.
1211   (unless nntp-async-timer
1212     (setq nntp-async-timer
1213           (nnheader-run-at-time 1 1 'nntp-async-timer-handler)))
1214   (add-to-list 'nntp-async-process-list process))
1215
1216 (defun nntp-async-timer-handler ()
1217   (mapcar
1218    (lambda (proc)
1219      (if (memq (process-status proc) '(open run))
1220          (nntp-async-trigger proc)
1221        (nntp-async-stop proc)))
1222    nntp-async-process-list))
1223
1224 (defun nntp-async-stop (proc)
1225   (setq nntp-async-process-list (delq proc nntp-async-process-list))
1226   (when (and nntp-async-timer (not nntp-async-process-list))
1227     (nnheader-cancel-timer nntp-async-timer)
1228     (setq nntp-async-timer nil)))
1229
1230 (defun nntp-after-change-function (beg end len)
1231   (unwind-protect
1232       ;; we only care about insertions at eob
1233       (when (and (eq 0 len) (eq (point-max) end))
1234         (save-match-data
1235           (let ((proc (get-buffer-process (current-buffer))))
1236             (when proc
1237               (nntp-async-trigger proc)))))
1238     ;; any throw from after-change-functions will leave it
1239     ;; set to nil.  so we reset it here, if necessary.
1240     (when quit-flag
1241       (setq after-change-functions '(nntp-after-change-function)))))
1242
1243 (defun nntp-async-trigger (process)
1244   (save-excursion
1245     (set-buffer (process-buffer process))
1246     (when nntp-process-callback
1247       ;; do we have an error message?
1248       (goto-char nntp-process-start-point)
1249       (if (memq (following-char) '(?4 ?5))
1250           ;; wants credentials?
1251           (if (looking-at "480")
1252               (nntp-handle-authinfo process)
1253             ;; report error message.
1254             (nntp-snarf-error-message)
1255             (nntp-do-callback nil))
1256
1257         ;; got what we expect?
1258         (goto-char (point-max))
1259         (when (re-search-backward
1260                nntp-process-wait-for nntp-process-start-point t)
1261           (let ((response (match-string 0)))
1262             (with-current-buffer nntp-server-buffer
1263               (setq nntp-process-response response)))
1264           (nntp-async-stop process)
1265           ;; convert it.
1266           (when (gnus-buffer-exists-p nntp-process-to-buffer)
1267             (let ((buf (current-buffer))
1268                   (start nntp-process-start-point)
1269                   (decode nntp-process-decode))
1270               (save-excursion
1271                 (set-buffer nntp-process-to-buffer)
1272                 (goto-char (point-max))
1273                 (save-restriction
1274                   (narrow-to-region (point) (point))
1275                   (insert-buffer-substring buf start)
1276                   (when decode
1277                     (nntp-decode-text))))))
1278           ;; report it.
1279           (goto-char (point-max))
1280           (nntp-do-callback
1281            (buffer-name (get-buffer nntp-process-to-buffer))))))))
1282
1283 (defun nntp-do-callback (arg)
1284   (let ((callback nntp-process-callback)
1285         (nntp-inside-change-function t))
1286     (setq nntp-process-callback nil)
1287     (funcall callback arg)))
1288
1289 (defun nntp-snarf-error-message ()
1290   "Save the error message in the current buffer."
1291   (let ((message (buffer-string)))
1292     (while (string-match "[\r\n]+" message)
1293       (setq message (replace-match " " t t message)))
1294     (nnheader-report 'nntp message)
1295     message))
1296
1297 (defun nntp-accept-process-output (process)
1298   "Wait for output from PROCESS and message some dots."
1299   (save-excursion
1300     (set-buffer (or (nntp-find-connection-buffer nntp-server-buffer)
1301                     nntp-server-buffer))
1302     (let ((len (/ (buffer-size) 1024))
1303           message-log-max)
1304       (unless (< len 10)
1305         (setq nntp-have-messaged t)
1306         (nnheader-message 7 "nntp read: %dk" len)))
1307     (nnheader-accept-process-output process)
1308     ;; accept-process-output may update status of process to indicate
1309     ;; that the server has closed the connection.  This MUST be
1310     ;; handled here as the buffer restored by the save-excursion may
1311     ;; be the process's former output buffer (i.e. now killed)
1312     (or (and process
1313              (memq (process-status process) '(open run)))
1314         (nntp-report "Server closed connection"))))
1315
1316 (defun nntp-accept-response ()
1317   "Wait for output from the process that outputs to BUFFER."
1318   (nntp-accept-process-output (nntp-find-connection nntp-server-buffer)))
1319
1320 (defun nntp-possibly-change-group (group server &optional connectionless)
1321   (let ((nnheader-callback-function nil))
1322     (when server
1323       (or (nntp-server-opened server)
1324           (nntp-open-server server nil connectionless)))
1325
1326     (unless connectionless
1327       (or (nntp-find-connection nntp-server-buffer)
1328           (nntp-open-connection nntp-server-buffer))))
1329
1330   (when group
1331     (let ((entry (nntp-find-connection-entry nntp-server-buffer)))
1332       (cond ((not entry)
1333              (nntp-report "Server closed connection"))
1334             ((not (equal group (caddr entry)))
1335              (save-excursion
1336                (set-buffer (process-buffer (car entry)))
1337                (erase-buffer)
1338                (nntp-send-command "^[245].*\n" "GROUP" group)
1339                (setcar (cddr entry) group)
1340                (erase-buffer)
1341                (save-excursion
1342                  (set-buffer nntp-server-buffer)
1343                  (erase-buffer))))))))
1344
1345 (defun nntp-decode-text (&optional cr-only)
1346   "Decode the text in the current buffer."
1347   (goto-char (point-min))
1348   (while (search-forward "\r" nil t)
1349     (delete-char -1))
1350   (unless cr-only
1351     ;; Remove trailing ".\n" end-of-transfer marker.
1352     (goto-char (point-max))
1353     (forward-line -1)
1354     (when (looking-at ".\n")
1355       (delete-char 2))
1356     ;; Delete status line.
1357     (goto-char (point-min))
1358     (while (looking-at "[1-5][0-9][0-9] .*\n")
1359       ;; For some unknown reason, there is more than one status line.
1360       (delete-region (point) (progn (forward-line 1) (point))))
1361     ;; Remove "." -> ".." encoding.
1362     (while (search-forward "\n.." nil t)
1363       (delete-char -1))))
1364
1365 (defun nntp-encode-text ()
1366   "Encode the text in the current buffer."
1367   (save-excursion
1368     ;; Replace "." at beginning of line with "..".
1369     (goto-char (point-min))
1370     (while (re-search-forward "^\\." nil t)
1371       (insert "."))
1372     (goto-char (point-max))
1373     ;; Insert newline at the end of the buffer.
1374     (unless (bolp)
1375       (insert "\n"))
1376     ;; Insert `.' at end of buffer (end of text mark).
1377     (goto-char (point-max))
1378     (insert ".\n")
1379     (goto-char (point-min))
1380     (while (not (eobp))
1381       (end-of-line)
1382       (delete-char 1)
1383       (insert nntp-end-of-line))))
1384
1385 (defun nntp-retrieve-headers-with-xover (articles &optional fetch-old)
1386   (set-buffer nntp-server-buffer)
1387   (erase-buffer)
1388   (cond
1389
1390    ;; This server does not talk NOV.
1391    ((not nntp-server-xover)
1392     nil)
1393
1394    ;; We don't care about gaps.
1395    ((or (not nntp-nov-gap)
1396         fetch-old)
1397     (nntp-send-xover-command
1398      (if fetch-old
1399          (if (numberp fetch-old)
1400              (max 1 (- (car articles) fetch-old))
1401            1)
1402        (car articles))
1403      (car (last articles)) 'wait)
1404
1405     (goto-char (point-min))
1406     (when (looking-at "[1-5][0-9][0-9] .*\n")
1407       (delete-region (point) (progn (forward-line 1) (point))))
1408     (while (search-forward "\r" nil t)
1409       (replace-match "" t t))
1410     (goto-char (point-max))
1411     (forward-line -1)
1412     (when (looking-at "\\.")
1413       (delete-region (point) (progn (forward-line 1) (point)))))
1414
1415    ;; We do it the hard way.  For each gap, an XOVER command is sent
1416    ;; to the server.  We do not wait for a reply from the server, we
1417    ;; just send them off as fast as we can.  That means that we have
1418    ;; to count the number of responses we get back to find out when we
1419    ;; have gotten all we asked for.
1420    ((numberp nntp-nov-gap)
1421     (let ((count 0)
1422           (received 0)
1423           last-point
1424           in-process-buffer-p
1425           (buf nntp-server-buffer)
1426           (process-buffer (nntp-find-connection-buffer nntp-server-buffer))
1427           first last status)
1428       ;; We have to check `nntp-server-xover'.  If it gets set to nil,
1429       ;; that means that the server does not understand XOVER, but we
1430       ;; won't know that until we try.
1431       (while (and nntp-server-xover articles)
1432         (setq first (car articles))
1433         ;; Search forward until we find a gap, or until we run out of
1434         ;; articles.
1435         (while (and (cdr articles)
1436                     (< (- (nth 1 articles) (car articles)) nntp-nov-gap))
1437           (setq articles (cdr articles)))
1438
1439         (setq in-process-buffer-p (stringp nntp-server-xover))
1440         (nntp-send-xover-command first (setq last (car articles)))
1441         (setq articles (cdr articles))
1442
1443         (when (and nntp-server-xover in-process-buffer-p)
1444           ;; Don't count tried request.
1445           (setq count (1+ count))
1446
1447           ;; Every 400 requests we have to read the stream in
1448           ;; order to avoid deadlocks.
1449           (when (or (null articles)     ;All requests have been sent.
1450                     (= 1 (% count nntp-maximum-request)))
1451
1452             (nntp-accept-response)
1453             ;; On some Emacs versions the preceding function has a
1454             ;; tendency to change the buffer.  Perhaps.  It's quite
1455             ;; difficult to reproduce, because it only seems to happen
1456             ;; once in a blue moon.
1457             (set-buffer process-buffer)
1458             (while (progn
1459                      (goto-char (or last-point (point-min)))
1460                      ;; Count replies.
1461                      (while (re-search-forward "^\\([0-9][0-9][0-9]\\) .*\n"
1462                                                nil t)
1463                        (incf received)
1464                        (setq status (match-string 1))
1465                        (if (string-match "^[45]" status)
1466                            (setq status 'error)
1467                          (setq status 'ok)))
1468                      (setq last-point (point))
1469                      (or (< received count)
1470                          (if (eq status 'error)
1471                              nil
1472                            ;; I haven't started reading the final response
1473                            (progn
1474                              (goto-char (point-max))
1475                              (forward-line -1)
1476                              (not (looking-at "^\\.\r?\n"))))))
1477               ;; I haven't read the end of the final response
1478               (nntp-accept-response)
1479               (set-buffer process-buffer))))
1480
1481         ;; Some nntp servers seem to have an extension to the XOVER
1482         ;; extension.  On these servers, requesting an article range
1483         ;; preceeding the active range does not return an error as
1484         ;; specified in the RFC.  What we instead get is the NOV entry
1485         ;; for the first available article.  Obviously, a client can
1486         ;; use that entry to avoid making unnecessary requests.  The
1487         ;; only problem is for a client that assumes that the response
1488         ;; will always be within the requested ranage.  For such a
1489         ;; client, we can get N copies of the same entry (one for each
1490         ;; XOVER command sent to the server).
1491
1492         (when (<= count 1)
1493           (goto-char (point-min))
1494           (when (re-search-forward "^[0-9][0-9][0-9] .*\n\\([0-9]+\\)" nil t)
1495             (let ((low-limit (string-to-int
1496                               (buffer-substring (match-beginning 1)
1497                                                 (match-end 1)))))
1498               (while (and articles (<= (car articles) low-limit))
1499                 (setq articles (cdr articles))))))
1500         (set-buffer buf))
1501
1502       (when nntp-server-xover
1503         (when in-process-buffer-p
1504           (set-buffer buf)
1505           (goto-char (point-max))
1506           (insert-buffer-substring process-buffer)
1507           (set-buffer process-buffer)
1508           (erase-buffer)
1509           (set-buffer buf))
1510
1511         ;; We remove any "." lines and status lines.
1512         (goto-char (point-min))
1513         (while (search-forward "\r" nil t)
1514           (delete-char -1))
1515         (goto-char (point-min))
1516         (delete-matching-lines "^\\.$\\|^[1-5][0-9][0-9] ")
1517         t))))
1518
1519   nntp-server-xover)
1520
1521 (defun nntp-send-xover-command (beg end &optional wait-for-reply)
1522   "Send the XOVER command to the server."
1523   (let ((range (format "%d-%d" beg end))
1524         (nntp-inhibit-erase t))
1525     (if (stringp nntp-server-xover)
1526         ;; If `nntp-server-xover' is a string, then we just send this
1527         ;; command.
1528         (if wait-for-reply
1529             (nntp-send-command-nodelete
1530              "\r?\n\\.\r?\n" nntp-server-xover range)
1531           ;; We do not wait for the reply.
1532           (nntp-send-command-nodelete nil nntp-server-xover range))
1533       (let ((commands nntp-xover-commands))
1534         ;; `nntp-xover-commands' is a list of possible XOVER commands.
1535         ;; We try them all until we get at positive response.
1536         (while (and commands (eq nntp-server-xover 'try))
1537           (nntp-send-command-nodelete "\r?\n\\.\r?\n" (car commands) range)
1538           (save-excursion
1539             (set-buffer nntp-server-buffer)
1540             (goto-char (point-min))
1541             (and (looking-at "[23]")    ; No error message.
1542                  ;; We also have to look at the lines.  Some buggy
1543                  ;; servers give back simple lines with just the
1544                  ;; article number.  How... helpful.
1545                  (progn
1546                    (forward-line 1)
1547                    (looking-at "[0-9]+\t...")) ; More text after number.
1548                  (setq nntp-server-xover (car commands))))
1549           (setq commands (cdr commands)))
1550         ;; If none of the commands worked, we disable XOVER.
1551         (when (eq nntp-server-xover 'try)
1552           (save-excursion
1553             (set-buffer nntp-server-buffer)
1554             (erase-buffer)
1555             (setq nntp-server-xover nil)))
1556         nntp-server-xover))))
1557
1558 (defun nntp-find-group-and-number (&optional group)
1559   (save-excursion
1560     (save-restriction
1561       (set-buffer nntp-server-buffer)
1562       (narrow-to-region (goto-char (point-min))
1563                         (or (search-forward "\n\n" nil t) (point-max)))
1564       (goto-char (point-min))
1565       ;; We first find the number by looking at the status line.
1566       (let ((number (and (looking-at "2[0-9][0-9] +\\([0-9]+\\) ")
1567                          (string-to-int
1568                           (buffer-substring (match-beginning 1)
1569                                             (match-end 1)))))
1570             newsgroups xref)
1571         (and number (zerop number) (setq number nil))
1572         (if number
1573             ;; Then we find the group name.
1574             (setq group
1575                   (cond
1576                    ;; If there is only one group in the Newsgroups
1577                    ;; header, then it seems quite likely that this
1578                    ;; article comes from that group, I'd say.
1579                    ((and (setq newsgroups
1580                                (mail-fetch-field "newsgroups"))
1581                          (not (string-match "," newsgroups)))
1582                     newsgroups)
1583                    ;; If there is more than one group in the
1584                    ;; Newsgroups header, then the Xref header should
1585                    ;; be filled out.  We hazard a guess that the group
1586                    ;; that has this article number in the Xref header
1587                    ;; is the one we are looking for.  This might very
1588                    ;; well be wrong if this article happens to have
1589                    ;; the same number in several groups, but that's
1590                    ;; life.
1591                    ((and (setq xref (mail-fetch-field "xref"))
1592                          number
1593                          (string-match
1594                           (format "\\([^ :]+\\):%d" number) xref))
1595                     (match-string 1 xref))
1596                    (t "")))
1597           (cond
1598            ((and (setq xref (mail-fetch-field "xref"))
1599                  (string-match
1600                   (if group
1601                       (concat "\\(" (regexp-quote group) "\\):\\([0-9]+\\)")
1602                     "\\([^ :]+\\):\\([0-9]+\\)")
1603                   xref))
1604             (setq group (match-string 1 xref)
1605                   number (string-to-int (match-string 2 xref))))
1606            ((and (setq newsgroups
1607                        (mail-fetch-field "newsgroups"))
1608                  (not (string-match "," newsgroups)))
1609             (setq group newsgroups))
1610            (group)
1611            (t (setq group ""))))
1612         (when (string-match "\r" group)
1613           (setq group (substring group 0 (match-beginning 0))))
1614         (cons group number)))))
1615
1616 (defun nntp-wait-for-string (regexp)
1617   "Wait until string arrives in the buffer."
1618   (let ((buf (current-buffer))
1619         proc)
1620     (goto-char (point-min))
1621     (while (and (setq proc (get-buffer-process buf))
1622                 (memq (process-status proc) '(open run))
1623                 (not (re-search-forward regexp nil t)))
1624       (accept-process-output proc)
1625       (set-buffer buf)
1626       (goto-char (point-min)))))
1627
1628
1629 ;; ==========================================================================
1630 ;; Obsolete nntp-open-* connection methods -- drv
1631 ;; ==========================================================================
1632
1633 (defvoo nntp-open-telnet-envuser nil
1634   "*If non-nil, telnet session (client and server both) will support the ENVIRON option and not prompt for login name.")
1635
1636 (defvoo nntp-telnet-shell-prompt "bash\\|\$ *\r?$\\|> *\r?"
1637   "*Regular expression to match the shell prompt on the remote machine.")
1638
1639 (defvoo nntp-rlogin-program "rsh"
1640   "*Program used to log in on remote machines.
1641 The default is \"rsh\", but \"ssh\" is a popular alternative.")
1642
1643 (defvoo nntp-rlogin-parameters '("telnet" "-8" "${NNTPSERVER:=news}" "nntp")
1644   "*Parameters to `nntp-open-rlogin'.
1645 That function may be used as `nntp-open-connection-function'.  In that
1646 case, this list will be used as the parameter list given to rsh.")
1647
1648 (defvoo nntp-rlogin-user-name nil
1649   "*User name on remote system when using the rlogin connect method.")
1650
1651 (defvoo nntp-telnet-parameters
1652     '("exec" "telnet" "-8" "${NNTPSERVER:=news}" "nntp")
1653   "*Parameters to `nntp-open-telnet'.
1654 That function may be used as `nntp-open-connection-function'.  In that
1655 case, this list will be executed as a command after logging in
1656 via telnet.")
1657
1658 (defvoo nntp-telnet-user-name nil
1659   "User name to log in via telnet with.")
1660
1661 (defvoo nntp-telnet-passwd nil
1662   "Password to use to log in via telnet with.")
1663
1664 (defun nntp-open-telnet (buffer)
1665   (save-excursion
1666     (set-buffer buffer)
1667     (erase-buffer)
1668     (let ((proc (apply
1669                  'start-process
1670                  "nntpd" buffer nntp-telnet-command nntp-telnet-switches))
1671           (case-fold-search t))
1672       (when (memq (process-status proc) '(open run))
1673         (nntp-wait-for-string "^r?telnet")
1674         (process-send-string proc "set escape \^X\n")
1675         (cond
1676          ((and nntp-open-telnet-envuser nntp-telnet-user-name)
1677           (process-send-string proc (concat "open " "-l" nntp-telnet-user-name
1678                                             nntp-address "\n")))
1679          (t
1680           (process-send-string proc (concat "open " nntp-address "\n"))))
1681         (cond
1682          ((not nntp-open-telnet-envuser)
1683           (nntp-wait-for-string "^\r*.?login:")
1684           (process-send-string
1685            proc (concat
1686                  (or nntp-telnet-user-name
1687                      (setq nntp-telnet-user-name (read-string "login: ")))
1688                  "\n"))))
1689         (nntp-wait-for-string "^\r*.?password:")
1690         (process-send-string
1691          proc (concat
1692                (or nntp-telnet-passwd
1693                    (setq nntp-telnet-passwd
1694                          (read-passwd "Password: ")))
1695                "\n"))
1696         (nntp-wait-for-string nntp-telnet-shell-prompt)
1697         (process-send-string
1698          proc (concat (mapconcat 'identity nntp-telnet-parameters " ") "\n"))
1699         (nntp-wait-for-string "^\r*20[01]")
1700         (beginning-of-line)
1701         (delete-region (point-min) (point))
1702         (process-send-string proc "\^]")
1703         (nntp-wait-for-string "^r?telnet")
1704         (process-send-string proc "mode character\n")
1705         (accept-process-output proc 1)
1706         (sit-for 1)
1707         (goto-char (point-min))
1708         (forward-line 1)
1709         (delete-region (point) (point-max)))
1710       proc)))
1711
1712 (defun nntp-open-rlogin (buffer)
1713   "Open a connection to SERVER using rsh."
1714   (let ((proc (if nntp-rlogin-user-name
1715                   (apply 'start-process
1716                          "nntpd" buffer nntp-rlogin-program
1717                          nntp-address "-l" nntp-rlogin-user-name
1718                          nntp-rlogin-parameters)
1719                 (apply 'start-process
1720                        "nntpd" buffer nntp-rlogin-program nntp-address
1721                        nntp-rlogin-parameters))))
1722     (save-excursion
1723       (set-buffer buffer)
1724       (nntp-wait-for-string "^\r*20[01]")
1725       (beginning-of-line)
1726       (delete-region (point-min) (point))
1727       proc)))
1728
1729
1730 ;; ==========================================================================
1731 ;; Replacements for the nntp-open-* functions -- drv
1732 ;; ==========================================================================
1733
1734 (defun nntp-open-telnet-stream (buffer)
1735   "Open a nntp connection by telnet'ing the news server.
1736
1737 Please refer to the following variables to customize the connection:
1738 - `nntp-pre-command',
1739 - `nntp-telnet-command',
1740 - `nntp-telnet-switches',
1741 - `nntp-address',
1742 - `nntp-port-number',
1743 - `nntp-end-of-line'."
1744   (let ((command `(,nntp-telnet-command
1745                    ,@nntp-telnet-switches
1746                    ,nntp-address ,nntp-port-number))
1747         proc)
1748     (and nntp-pre-command
1749          (push nntp-pre-command command))
1750     (setq proc (apply 'start-process "nntpd" buffer command))
1751     (save-excursion
1752       (set-buffer buffer)
1753       (nntp-wait-for-string "^\r*20[01]")
1754       (beginning-of-line)
1755       (delete-region (point-min) (point))
1756       proc)))
1757
1758 (defun nntp-open-via-rlogin-and-telnet (buffer)
1759   "Open a connection to an nntp server through an intermediate host.
1760 First rlogin to the remote host, and then telnet the real news server
1761 from there.
1762
1763 Please refer to the following variables to customize the connection:
1764 - `nntp-pre-command',
1765 - `nntp-via-rlogin-command',
1766 - `nntp-via-rlogin-command-switches',
1767 - `nntp-via-user-name',
1768 - `nntp-via-address',
1769 - `nntp-telnet-command',
1770 - `nntp-telnet-switches',
1771 - `nntp-address',
1772 - `nntp-port-number',
1773 - `nntp-end-of-line'."
1774   (let ((command `(,nntp-via-address
1775                    ,nntp-telnet-command
1776                    ,@nntp-telnet-switches))
1777         proc)
1778     (when nntp-via-user-name
1779       (setq command `("-l" ,nntp-via-user-name ,@command)))
1780     (when nntp-via-rlogin-command-switches
1781       (setq command (append nntp-via-rlogin-command-switches command)))
1782     (push nntp-via-rlogin-command command)
1783     (and nntp-pre-command
1784          (push nntp-pre-command command))
1785     (setq proc (apply 'start-process "nntpd" buffer command))
1786     (save-excursion
1787       (set-buffer buffer)
1788       (nntp-wait-for-string "^r?telnet")
1789       (process-send-string proc (concat "open " nntp-address
1790                                         " " nntp-port-number "\n"))
1791       (nntp-wait-for-string "^\r*20[01]")
1792       (beginning-of-line)
1793       (delete-region (point-min) (point))
1794       (process-send-string proc "\^]")
1795       (nntp-wait-for-string "^r?telnet")
1796       (process-send-string proc "mode character\n")
1797       (accept-process-output proc 1)
1798       (sit-for 1)
1799       (goto-char (point-min))
1800       (forward-line 1)
1801       (delete-region (point) (point-max)))
1802     proc))
1803
1804 (defun nntp-open-via-telnet-and-telnet (buffer)
1805   "Open a connection to an nntp server through an intermediate host.
1806 First telnet the remote host, and then telnet the real news server
1807 from there.
1808
1809 Please refer to the following variables to customize the connection:
1810 - `nntp-pre-command',
1811 - `nntp-via-telnet-command',
1812 - `nntp-via-telnet-switches',
1813 - `nntp-via-address',
1814 - `nntp-via-envuser',
1815 - `nntp-via-user-name',
1816 - `nntp-via-user-password',
1817 - `nntp-via-shell-prompt',
1818 - `nntp-telnet-command',
1819 - `nntp-telnet-switches',
1820 - `nntp-address',
1821 - `nntp-port-number',
1822 - `nntp-end-of-line'."
1823   (save-excursion
1824     (set-buffer buffer)
1825     (erase-buffer)
1826     (let ((command `(,nntp-via-telnet-command ,@nntp-via-telnet-switches))
1827           (case-fold-search t)
1828           proc)
1829       (and nntp-pre-command (push nntp-pre-command command))
1830       (setq proc (apply 'start-process "nntpd" buffer command))
1831       (when (memq (process-status proc) '(open run))
1832         (nntp-wait-for-string "^r?telnet")
1833         (process-send-string proc "set escape \^X\n")
1834         (cond
1835          ((and nntp-via-envuser nntp-via-user-name)
1836           (process-send-string proc (concat "open " "-l" nntp-via-user-name
1837                                             nntp-via-address "\n")))
1838          (t
1839           (process-send-string proc (concat "open " nntp-via-address
1840                                             "\n"))))
1841         (when (not nntp-via-envuser)
1842           (nntp-wait-for-string "^\r*.?login:")
1843           (process-send-string proc
1844                                (concat
1845                                 (or nntp-via-user-name
1846                                     (setq nntp-via-user-name
1847                                           (read-string "login: ")))
1848                                 "\n")))
1849         (nntp-wait-for-string "^\r*.?password:")
1850         (process-send-string proc
1851                              (concat
1852                               (or nntp-via-user-password
1853                                   (setq nntp-via-user-password
1854                                         (read-passwd "Password: ")))
1855                               "\n"))
1856         (nntp-wait-for-string nntp-via-shell-prompt)
1857         (let ((real-telnet-command `("exec"
1858                                      ,nntp-telnet-command
1859                                      ,@nntp-telnet-switches
1860                                      ,nntp-address
1861                                      ,nntp-port-number)))
1862           (process-send-string proc
1863                                (concat (mapconcat 'identity
1864                                                   real-telnet-command " ")
1865                                        "\n")))
1866         (nntp-wait-for-string "^\r*20[01]")
1867         (beginning-of-line)
1868         (delete-region (point-min) (point))
1869         (process-send-string proc "\^]")
1870         (nntp-wait-for-string "^r?telnet")
1871         (process-send-string proc "mode character\n")
1872         (accept-process-output proc 1)
1873         (sit-for 1)
1874         (goto-char (point-min))
1875         (forward-line 1)
1876         (delete-region (point) (point-max)))
1877       proc)))
1878
1879 (provide 'nntp)
1880
1881 ;;; nntp.el ends here