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