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   (nntp-possibly-create-directory group server)
1095   (unless nntp-marks-is-evil
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   (nntp-possibly-create-directory group server)
1115   (when (and (not nntp-marks-is-evil) (nntp-marks-changed-p group server))
1116     (nnheader-message 8 "Updating marks for %s..." group)
1117     (nntp-open-marks group server)
1118     ;; Update info using `nntp-marks'.
1119     (mapc (lambda (pred)
1120             (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists)
1121               (gnus-info-set-marks
1122                info
1123                (gnus-update-alist-soft
1124                 (cdr pred)
1125                 (cdr (assq (cdr pred) nntp-marks))
1126                 (gnus-info-marks info))
1127                t)))
1128           gnus-article-mark-lists)
1129     (let ((seen (cdr (assq 'read nntp-marks))))
1130       (gnus-info-set-read info
1131                           (if (and (integerp (car seen))
1132                                    (null (cdr seen)))
1133                               (list (cons (car seen) (car seen)))
1134                             seen)))
1135     (nnheader-message 8 "Updating marks for %s...done" group))
1136   info)
1137
1138
1139
1140 ;;; Hooky functions.
1141
1142 (defun nntp-send-mode-reader ()
1143   "Send the MODE READER command to the nntp server.
1144 This function is supposed to be called from `nntp-server-opened-hook'.
1145 It will make innd servers spawn an nnrpd process to allow actual article
1146 reading."
1147   (nntp-send-command "^.*\n" "MODE READER"))
1148
1149 (defun nntp-send-authinfo (&optional send-if-force)
1150   "Send the AUTHINFO to the nntp server.
1151 It will look in the \"~/.authinfo\" file for matching entries.  If
1152 nothing suitable is found there, it will prompt for a user name
1153 and a password.
1154
1155 If SEND-IF-FORCE, only send authinfo to the server if the
1156 .authinfo file has the FORCE token."
1157   (let* ((list (gnus-parse-netrc nntp-authinfo-file))
1158          (alist (gnus-netrc-machine list nntp-address "nntp"))
1159          (force (gnus-netrc-get alist "force"))
1160          (user (or (gnus-netrc-get alist "login") nntp-authinfo-user))
1161          (passwd (gnus-netrc-get alist "password")))
1162     (when (or (not send-if-force)
1163               force)
1164       (unless user
1165         (setq user (read-string (format "NNTP (%s) user name: " nntp-address))
1166               nntp-authinfo-user user))
1167       (unless (member user '(nil ""))
1168         (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" user)
1169         (when t                         ;???Should check if AUTHINFO succeeded
1170           (nntp-send-command
1171            "^2.*\r?\n" "AUTHINFO PASS"
1172            (or passwd
1173                nntp-authinfo-password
1174                (setq nntp-authinfo-password
1175                      (read-passwd (format "NNTP (%s@%s) password: "
1176                                           user nntp-address))))))))))
1177
1178 (defun nntp-send-nosy-authinfo ()
1179   "Send the AUTHINFO to the nntp server."
1180   (let ((user (read-string (format "NNTP (%s) user name: " nntp-address))))
1181     (unless (member user '(nil ""))
1182       (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" user)
1183       (when t                           ;???Should check if AUTHINFO succeeded
1184         (nntp-send-command "^2.*\r?\n" "AUTHINFO PASS"
1185                            (read-passwd (format "NNTP (%s@%s) password: "
1186                                                 user nntp-address)))))))
1187
1188 (defun nntp-send-authinfo-from-file ()
1189   "Send the AUTHINFO to the nntp server.
1190
1191 The authinfo login name is taken from the user's login name and the
1192 password contained in '~/.nntp-authinfo'."
1193   (when (file-exists-p "~/.nntp-authinfo")
1194     (with-temp-buffer
1195       (insert-file-contents "~/.nntp-authinfo")
1196       (goto-char (point-min))
1197       (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" (user-login-name))
1198       (nntp-send-command
1199        "^2.*\r?\n" "AUTHINFO PASS"
1200        (buffer-substring (point) (point-at-eol))))))
1201
1202 ;;; Internal functions.
1203
1204 (defun nntp-handle-authinfo (process)
1205   "Take care of an authinfo response from the server."
1206   (let ((last nntp-last-command))
1207     (funcall nntp-authinfo-function)
1208     ;; We have to re-send the function that was interrupted by
1209     ;; the authinfo request.
1210     (nntp-erase-buffer nntp-server-buffer)
1211     (nntp-send-string process last)))
1212
1213 (defun nntp-make-process-buffer (buffer)
1214   "Create a new, fresh buffer usable for nntp process connections."
1215   (save-excursion
1216     (set-buffer
1217      (generate-new-buffer
1218       (format " *server %s %s %s*"
1219               nntp-address nntp-port-number
1220               (gnus-buffer-exists-p buffer))))
1221     (set (make-local-variable 'after-change-functions) nil)
1222     (set (make-local-variable 'nntp-process-wait-for) nil)
1223     (set (make-local-variable 'nntp-process-callback) nil)
1224     (set (make-local-variable 'nntp-process-to-buffer) nil)
1225     (set (make-local-variable 'nntp-process-start-point) nil)
1226     (set (make-local-variable 'nntp-process-decode) nil)
1227     (current-buffer)))
1228
1229 (defun nntp-open-connection (buffer)
1230   "Open a connection to PORT on ADDRESS delivering output to BUFFER."
1231   (run-hooks 'nntp-prepare-server-hook)
1232   (let* ((pbuffer (nntp-make-process-buffer buffer))
1233          (timer
1234           (and nntp-connection-timeout
1235                (run-at-time
1236                 nntp-connection-timeout nil
1237                 `(lambda ()
1238                    (nntp-kill-buffer ,pbuffer)))))
1239          (process
1240           (condition-case ()
1241               (funcall nntp-open-connection-function pbuffer)
1242             (error nil)
1243             (quit
1244              (message "Quit opening connection")
1245              (nntp-kill-buffer pbuffer)
1246              (signal 'quit nil)
1247              nil))))
1248     (when timer
1249       (nnheader-cancel-timer timer))
1250     (unless process
1251       (nntp-kill-buffer pbuffer))
1252     (when (and (buffer-name pbuffer)
1253                process)
1254       (process-kill-without-query process)
1255       (if (and (nntp-wait-for process "^2.*\n" buffer nil t)
1256                (memq (process-status process) '(open run)))
1257           (prog1
1258               (caar (push (list process buffer nil) nntp-connection-alist))
1259             (push process nntp-connection-list)
1260             (save-excursion
1261               (set-buffer pbuffer)
1262               (nntp-read-server-type)
1263               (erase-buffer)
1264               (set-buffer nntp-server-buffer)
1265               (let ((nnheader-callback-function nil))
1266                 (run-hooks 'nntp-server-opened-hook)
1267                 (nntp-send-authinfo t))))
1268         (nntp-kill-buffer (process-buffer process))
1269         nil))))
1270
1271 (defun nntp-open-network-stream (buffer)
1272   (open-network-stream-as-binary
1273    "nntpd" buffer nntp-address nntp-port-number))
1274
1275 (autoload 'format-spec "format")
1276 (autoload 'format-spec-make "format")
1277 (autoload 'open-tls-stream "tls")
1278
1279 (defun nntp-open-ssl-stream (buffer)
1280   (let* ((process-connection-type nil)
1281          (proc (as-binary-process
1282                 (start-process "nntpd" buffer
1283                                shell-file-name
1284                                shell-command-switch
1285                                (format-spec nntp-ssl-program
1286                                             (format-spec-make
1287                                              ?s nntp-address
1288                                              ?p nntp-port-number))))))
1289     (process-kill-without-query proc)
1290     (save-excursion
1291       (set-buffer buffer)
1292       (let ((nntp-connection-alist (list proc buffer nil)))
1293         (nntp-wait-for-string "^\r*20[01]"))
1294       (beginning-of-line)
1295       (delete-region (point-min) (point))
1296       proc)))
1297
1298 (defun nntp-open-tls-stream (buffer)
1299   (let ((proc (open-tls-stream "nntpd" buffer nntp-address nntp-port-number)))
1300     (process-kill-without-query proc)
1301     (save-excursion
1302       (set-buffer buffer)
1303       (let ((nntp-connection-alist (list proc buffer nil)))
1304         (nntp-wait-for-string "^\r*20[01]"))
1305       (beginning-of-line)
1306       (delete-region (point-min) (point))
1307       proc)))
1308
1309 (defun nntp-read-server-type ()
1310   "Find out what the name of the server we have connected to is."
1311   ;; Wait for the status string to arrive.
1312   (setq nntp-server-type (buffer-string))
1313   (let ((alist nntp-server-action-alist)
1314         (case-fold-search t)
1315         entry)
1316     ;; Run server-specific commands.
1317     (while alist
1318       (setq entry (pop alist))
1319       (when (string-match (car entry) nntp-server-type)
1320         (if (and (listp (cadr entry))
1321                  (not (eq 'lambda (caadr entry))))
1322             (eval (cadr entry))
1323           (funcall (cadr entry)))))))
1324
1325 (defun nntp-async-wait (process wait-for buffer decode callback)
1326   (save-excursion
1327     (set-buffer (process-buffer process))
1328     (unless nntp-inside-change-function
1329       (erase-buffer))
1330     (setq nntp-process-wait-for wait-for
1331           nntp-process-to-buffer buffer
1332           nntp-process-decode decode
1333           nntp-process-callback callback
1334           nntp-process-start-point (point-max))
1335     (setq after-change-functions '(nntp-after-change-function))
1336     (if nntp-async-needs-kluge
1337         (nntp-async-kluge process))))
1338
1339 (defun nntp-async-kluge (process)
1340   ;; emacs 20.3 bug: process output with encoding 'binary
1341   ;; doesn't trigger after-change-functions.
1342   (unless nntp-async-timer
1343     (setq nntp-async-timer
1344           (run-at-time 1 1 'nntp-async-timer-handler)))
1345   (add-to-list 'nntp-async-process-list process))
1346
1347 (defun nntp-async-timer-handler ()
1348   (mapcar
1349    (lambda (proc)
1350      (if (memq (process-status proc) '(open run))
1351          (nntp-async-trigger proc)
1352        (nntp-async-stop proc)))
1353    nntp-async-process-list))
1354
1355 (defun nntp-async-stop (proc)
1356   (setq nntp-async-process-list (delq proc nntp-async-process-list))
1357   (when (and nntp-async-timer (not nntp-async-process-list))
1358     (nnheader-cancel-timer nntp-async-timer)
1359     (setq nntp-async-timer nil)))
1360
1361 (defun nntp-after-change-function (beg end len)
1362   (unwind-protect
1363       ;; we only care about insertions at eob
1364       (when (and (eq 0 len) (eq (point-max) end))
1365         (save-match-data
1366           (let ((proc (get-buffer-process (current-buffer))))
1367             (when proc
1368               (nntp-async-trigger proc)))))
1369     ;; any throw from after-change-functions will leave it
1370     ;; set to nil.  so we reset it here, if necessary.
1371     (when quit-flag
1372       (setq after-change-functions '(nntp-after-change-function)))))
1373
1374 (defun nntp-async-trigger (process)
1375   (save-excursion
1376     (set-buffer (process-buffer process))
1377     (when nntp-process-callback
1378       ;; do we have an error message?
1379       (goto-char nntp-process-start-point)
1380       (if (memq (following-char) '(?4 ?5))
1381           ;; wants credentials?
1382           (if (looking-at "480")
1383               (nntp-handle-authinfo process)
1384             ;; report error message.
1385             (nntp-snarf-error-message)
1386             (nntp-do-callback nil))
1387
1388         ;; got what we expect?
1389         (goto-char (point-max))
1390         (when (re-search-backward
1391                nntp-process-wait-for nntp-process-start-point t)
1392           (let ((response (match-string 0)))
1393             (with-current-buffer nntp-server-buffer
1394               (setq nntp-process-response response)))
1395           (nntp-async-stop process)
1396           ;; convert it.
1397           (when (gnus-buffer-exists-p nntp-process-to-buffer)
1398             (let ((buf (current-buffer))
1399                   (start nntp-process-start-point)
1400                   (decode nntp-process-decode))
1401               (save-excursion
1402                 (set-buffer nntp-process-to-buffer)
1403                 (goto-char (point-max))
1404                 (save-restriction
1405                   (narrow-to-region (point) (point))
1406                   (insert-buffer-substring buf start)
1407                   (when decode
1408                     (nntp-decode-text))))))
1409           ;; report it.
1410           (goto-char (point-max))
1411           (nntp-do-callback
1412            (buffer-name (get-buffer nntp-process-to-buffer))))))))
1413
1414 (defun nntp-do-callback (arg)
1415   (let ((callback nntp-process-callback)
1416         (nntp-inside-change-function t))
1417     (setq nntp-process-callback nil)
1418     (funcall callback arg)))
1419
1420 (defun nntp-snarf-error-message ()
1421   "Save the error message in the current buffer."
1422   (let ((message (buffer-string)))
1423     (while (string-match "[\r\n]+" message)
1424       (setq message (replace-match " " t t message)))
1425     (nnheader-report 'nntp message)
1426     message))
1427
1428 (defun nntp-accept-process-output (process)
1429   "Wait for output from PROCESS and message some dots."
1430   (save-excursion
1431     (set-buffer (or (nntp-find-connection-buffer nntp-server-buffer)
1432                     nntp-server-buffer))
1433     (let ((len (/ (buffer-size) 1024))
1434           message-log-max)
1435       (unless (< len 10)
1436         (setq nntp-have-messaged t)
1437         (nnheader-message 7 "nntp read: %dk" len)))
1438     (nnheader-accept-process-output process)
1439     ;; accept-process-output may update status of process to indicate
1440     ;; that the server has closed the connection.  This MUST be
1441     ;; handled here as the buffer restored by the save-excursion may
1442     ;; be the process's former output buffer (i.e. now killed)
1443     (or (and process
1444              (memq (process-status process) '(open run)))
1445         (nntp-report "Server closed connection"))))
1446
1447 (defun nntp-accept-response ()
1448   "Wait for output from the process that outputs to BUFFER."
1449   (nntp-accept-process-output (nntp-find-connection nntp-server-buffer)))
1450
1451 (defun nntp-possibly-change-group (group server &optional connectionless)
1452   (let ((nnheader-callback-function nil))
1453     (when server
1454       (or (nntp-server-opened server)
1455           (nntp-open-server server nil connectionless)))
1456
1457     (unless connectionless
1458       (or (nntp-find-connection nntp-server-buffer)
1459           (nntp-open-connection nntp-server-buffer))))
1460
1461   (when group
1462     (let ((entry (nntp-find-connection-entry nntp-server-buffer)))
1463       (cond ((not entry)
1464              (nntp-report "Server closed connection"))
1465             ((not (equal group (caddr entry)))
1466              (save-excursion
1467                (set-buffer (process-buffer (car entry)))
1468                (erase-buffer)
1469                (nntp-send-command "^[245].*\n" "GROUP" group)
1470                (setcar (cddr entry) group)
1471                (erase-buffer)
1472                (nntp-erase-buffer nntp-server-buffer)))))))
1473
1474 (defun nntp-decode-text (&optional cr-only)
1475   "Decode the text in the current buffer."
1476   (goto-char (point-min))
1477   (while (search-forward "\r" nil t)
1478     (delete-char -1))
1479   (unless cr-only
1480     ;; Remove trailing ".\n" end-of-transfer marker.
1481     (goto-char (point-max))
1482     (forward-line -1)
1483     (when (looking-at ".\n")
1484       (delete-char 2))
1485     ;; Delete status line.
1486     (goto-char (point-min))
1487     (while (looking-at "[1-5][0-9][0-9] .*\n")
1488       ;; For some unknown reason, there is more than one status line.
1489       (delete-region (point) (progn (forward-line 1) (point))))
1490     ;; Remove "." -> ".." encoding.
1491     (while (search-forward "\n.." nil t)
1492       (delete-char -1))))
1493
1494 (defun nntp-encode-text ()
1495   "Encode the text in the current buffer."
1496   (save-excursion
1497     ;; Replace "." at beginning of line with "..".
1498     (goto-char (point-min))
1499     (while (re-search-forward "^\\." nil t)
1500       (insert "."))
1501     (goto-char (point-max))
1502     ;; Insert newline at the end of the buffer.
1503     (unless (bolp)
1504       (insert "\n"))
1505     ;; Insert `.' at end of buffer (end of text mark).
1506     (goto-char (point-max))
1507     (insert ".\n")
1508     (goto-char (point-min))
1509     (while (not (eobp))
1510       (end-of-line)
1511       (delete-char 1)
1512       (insert nntp-end-of-line))))
1513
1514 (defun nntp-retrieve-headers-with-xover (articles &optional fetch-old)
1515   (set-buffer nntp-server-buffer)
1516   (erase-buffer)
1517   (cond
1518
1519    ;; This server does not talk NOV.
1520    ((not nntp-server-xover)
1521     nil)
1522
1523    ;; We don't care about gaps.
1524    ((or (not nntp-nov-gap)
1525         fetch-old)
1526     (nntp-send-xover-command
1527      (if fetch-old
1528          (if (numberp fetch-old)
1529              (max 1 (- (car articles) fetch-old))
1530            1)
1531        (car articles))
1532      (car (last articles)) 'wait)
1533
1534     (goto-char (point-min))
1535     (when (looking-at "[1-5][0-9][0-9] .*\n")
1536       (delete-region (point) (progn (forward-line 1) (point))))
1537     (while (search-forward "\r" nil t)
1538       (replace-match "" t t))
1539     (goto-char (point-max))
1540     (forward-line -1)
1541     (when (looking-at "\\.")
1542       (delete-region (point) (progn (forward-line 1) (point)))))
1543
1544    ;; We do it the hard way.  For each gap, an XOVER command is sent
1545    ;; to the server.  We do not wait for a reply from the server, we
1546    ;; just send them off as fast as we can.  That means that we have
1547    ;; to count the number of responses we get back to find out when we
1548    ;; have gotten all we asked for.
1549    ((numberp nntp-nov-gap)
1550     (let ((count 0)
1551           (received 0)
1552           last-point
1553           in-process-buffer-p
1554           (buf nntp-server-buffer)
1555           (process-buffer (nntp-find-connection-buffer nntp-server-buffer))
1556           first last status)
1557       ;; We have to check `nntp-server-xover'.  If it gets set to nil,
1558       ;; that means that the server does not understand XOVER, but we
1559       ;; won't know that until we try.
1560       (while (and nntp-server-xover articles)
1561         (setq first (car articles))
1562         ;; Search forward until we find a gap, or until we run out of
1563         ;; articles.
1564         (while (and (cdr articles)
1565                     (< (- (nth 1 articles) (car articles)) nntp-nov-gap))
1566           (setq articles (cdr articles)))
1567
1568         (setq in-process-buffer-p (stringp nntp-server-xover))
1569         (nntp-send-xover-command first (setq last (car articles)))
1570         (setq articles (cdr articles))
1571
1572         (when (and nntp-server-xover in-process-buffer-p)
1573           ;; Don't count tried request.
1574           (setq count (1+ count))
1575
1576           ;; Every 400 requests we have to read the stream in
1577           ;; order to avoid deadlocks.
1578           (when (or (null articles)     ;All requests have been sent.
1579                     (= 1 (% count nntp-maximum-request)))
1580
1581             (nntp-accept-response)
1582             ;; On some Emacs versions the preceding function has a
1583             ;; tendency to change the buffer.  Perhaps.  It's quite
1584             ;; difficult to reproduce, because it only seems to happen
1585             ;; once in a blue moon.
1586             (set-buffer process-buffer)
1587             (while (progn
1588                      (goto-char (or last-point (point-min)))
1589                      ;; Count replies.
1590                      (while (re-search-forward "^\\([0-9][0-9][0-9]\\) .*\n"
1591                                                nil t)
1592                        (incf received)
1593                        (setq status (match-string 1))
1594                        (if (string-match "^[45]" status)
1595                            (setq status 'error)
1596                          (setq status 'ok)))
1597                      (setq last-point (point))
1598                      (or (< received count)
1599                          (if (eq status 'error)
1600                              nil
1601                            ;; I haven't started reading the final response
1602                            (progn
1603                              (goto-char (point-max))
1604                              (forward-line -1)
1605                              (not (looking-at "^\\.\r?\n"))))))
1606               ;; I haven't read the end of the final response
1607               (nntp-accept-response)
1608               (set-buffer process-buffer))))
1609
1610         ;; Some nntp servers seem to have an extension to the XOVER
1611         ;; extension.  On these servers, requesting an article range
1612         ;; preceeding the active range does not return an error as
1613         ;; specified in the RFC.  What we instead get is the NOV entry
1614         ;; for the first available article.  Obviously, a client can
1615         ;; use that entry to avoid making unnecessary requests.  The
1616         ;; only problem is for a client that assumes that the response
1617         ;; will always be within the requested ranage.  For such a
1618         ;; client, we can get N copies of the same entry (one for each
1619         ;; XOVER command sent to the server).
1620
1621         (when (<= count 1)
1622           (goto-char (point-min))
1623           (when (re-search-forward "^[0-9][0-9][0-9] .*\n\\([0-9]+\\)" nil t)
1624             (let ((low-limit (string-to-int
1625                               (buffer-substring (match-beginning 1)
1626                                                 (match-end 1)))))
1627               (while (and articles (<= (car articles) low-limit))
1628                 (setq articles (cdr articles))))))
1629         (set-buffer buf))
1630
1631       (when nntp-server-xover
1632         (when in-process-buffer-p
1633           (set-buffer buf)
1634           (goto-char (point-max))
1635           (insert-buffer-substring process-buffer)
1636           (set-buffer process-buffer)
1637           (erase-buffer)
1638           (set-buffer buf))
1639
1640         ;; We remove any "." lines and status lines.
1641         (goto-char (point-min))
1642         (while (search-forward "\r" nil t)
1643           (delete-char -1))
1644         (goto-char (point-min))
1645         (delete-matching-lines "^\\.$\\|^[1-5][0-9][0-9] ")
1646         t))))
1647
1648   nntp-server-xover)
1649
1650 (defun nntp-send-xover-command (beg end &optional wait-for-reply)
1651   "Send the XOVER command to the server."
1652   (let ((range (format "%d-%d" beg end))
1653         (nntp-inhibit-erase t))
1654     (if (stringp nntp-server-xover)
1655         ;; If `nntp-server-xover' is a string, then we just send this
1656         ;; command.
1657         (if wait-for-reply
1658             (nntp-send-command-nodelete
1659              "\r?\n\\.\r?\n" nntp-server-xover range)
1660           ;; We do not wait for the reply.
1661           (nntp-send-command-nodelete nil nntp-server-xover range))
1662       (let ((commands nntp-xover-commands))
1663         ;; `nntp-xover-commands' is a list of possible XOVER commands.
1664         ;; We try them all until we get at positive response.
1665         (while (and commands (eq nntp-server-xover 'try))
1666           (nntp-send-command-nodelete "\r?\n\\.\r?\n" (car commands) range)
1667           (save-excursion
1668             (set-buffer nntp-server-buffer)
1669             (goto-char (point-min))
1670             (and (looking-at "[23]")    ; No error message.
1671                  ;; We also have to look at the lines.  Some buggy
1672                  ;; servers give back simple lines with just the
1673                  ;; article number.  How... helpful.
1674                  (progn
1675                    (forward-line 1)
1676                    (looking-at "[0-9]+\t...")) ; More text after number.
1677                  (setq nntp-server-xover (car commands))))
1678           (setq commands (cdr commands)))
1679         ;; If none of the commands worked, we disable XOVER.
1680         (when (eq nntp-server-xover 'try)
1681           (nntp-erase-buffer nntp-server-buffer)
1682           (setq nntp-server-xover nil))
1683         nntp-server-xover))))
1684
1685 (defun nntp-find-group-and-number (&optional group)
1686   (save-excursion
1687     (save-restriction
1688       (set-buffer nntp-server-buffer)
1689       (narrow-to-region (goto-char (point-min))
1690                         (or (search-forward "\n\n" nil t) (point-max)))
1691       (goto-char (point-min))
1692       ;; We first find the number by looking at the status line.
1693       (let ((number (and (looking-at "2[0-9][0-9] +\\([0-9]+\\) ")
1694                          (string-to-int
1695                           (buffer-substring (match-beginning 1)
1696                                             (match-end 1)))))
1697             newsgroups xref)
1698         (and number (zerop number) (setq number nil))
1699         (if number
1700             ;; Then we find the group name.
1701             (setq group
1702                   (cond
1703                    ;; If there is only one group in the Newsgroups
1704                    ;; header, then it seems quite likely that this
1705                    ;; article comes from that group, I'd say.
1706                    ((and (setq newsgroups
1707                                (mail-fetch-field "newsgroups"))
1708                          (not (string-match "," newsgroups)))
1709                     newsgroups)
1710                    ;; If there is more than one group in the
1711                    ;; Newsgroups header, then the Xref header should
1712                    ;; be filled out.  We hazard a guess that the group
1713                    ;; that has this article number in the Xref header
1714                    ;; is the one we are looking for.  This might very
1715                    ;; well be wrong if this article happens to have
1716                    ;; the same number in several groups, but that's
1717                    ;; life.
1718                    ((and (setq xref (mail-fetch-field "xref"))
1719                          number
1720                          (string-match
1721                           (format "\\([^ :]+\\):%d" number) xref))
1722                     (match-string 1 xref))
1723                    (t "")))
1724           (cond
1725            ((and (setq xref (mail-fetch-field "xref"))
1726                  (string-match
1727                   (if group
1728                       (concat "\\(" (regexp-quote group) "\\):\\([0-9]+\\)")
1729                     "\\([^ :]+\\):\\([0-9]+\\)")
1730                   xref))
1731             (setq group (match-string 1 xref)
1732                   number (string-to-int (match-string 2 xref))))
1733            ((and (setq newsgroups
1734                        (mail-fetch-field "newsgroups"))
1735                  (not (string-match "," newsgroups)))
1736             (setq group newsgroups))
1737            (group)
1738            (t (setq group ""))))
1739         (when (string-match "\r" group)
1740           (setq group (substring group 0 (match-beginning 0))))
1741         (cons group number)))))
1742
1743 (defun nntp-wait-for-string (regexp)
1744   "Wait until string arrives in the buffer."
1745   (let ((buf (current-buffer))
1746         proc)
1747     (goto-char (point-min))
1748     (while (and (setq proc (get-buffer-process buf))
1749                 (memq (process-status proc) '(open run))
1750                 (not (re-search-forward regexp nil t)))
1751       (accept-process-output proc)
1752       (set-buffer buf)
1753       (goto-char (point-min)))))
1754
1755
1756 ;; ==========================================================================
1757 ;; Obsolete nntp-open-* connection methods -- drv
1758 ;; ==========================================================================
1759
1760 (defvoo nntp-open-telnet-envuser nil
1761   "*If non-nil, telnet session (client and server both) will support the ENVIRON option and not prompt for login name.")
1762
1763 (defvoo nntp-telnet-shell-prompt "bash\\|\$ *\r?$\\|> *\r?"
1764   "*Regular expression to match the shell prompt on the remote machine.")
1765
1766 (defvoo nntp-rlogin-program "rsh"
1767   "*Program used to log in on remote machines.
1768 The default is \"rsh\", but \"ssh\" is a popular alternative.")
1769
1770 (defvoo nntp-rlogin-parameters '("telnet" "-8" "${NNTPSERVER:=news}" "nntp")
1771   "*Parameters to `nntp-open-rlogin'.
1772 That function may be used as `nntp-open-connection-function'.  In that
1773 case, this list will be used as the parameter list given to rsh.")
1774
1775 (defvoo nntp-rlogin-user-name nil
1776   "*User name on remote system when using the rlogin connect method.")
1777
1778 (defvoo nntp-telnet-parameters
1779     '("exec" "telnet" "-8" "${NNTPSERVER:=news}" "nntp")
1780   "*Parameters to `nntp-open-telnet'.
1781 That function may be used as `nntp-open-connection-function'.  In that
1782 case, this list will be executed as a command after logging in
1783 via telnet.")
1784
1785 (defvoo nntp-telnet-user-name nil
1786   "User name to log in via telnet with.")
1787
1788 (defvoo nntp-telnet-passwd nil
1789   "Password to use to log in via telnet with.")
1790
1791 (defun nntp-open-telnet (buffer)
1792   (save-excursion
1793     (set-buffer buffer)
1794     (erase-buffer)
1795     (let ((proc (as-binary-process
1796                  (apply
1797                   'start-process
1798                   "nntpd" buffer nntp-telnet-command nntp-telnet-switches)))
1799           (case-fold-search t))
1800       (when (memq (process-status proc) '(open run))
1801         (nntp-wait-for-string "^r?telnet")
1802         (process-send-string proc "set escape \^X\n")
1803         (cond
1804          ((and nntp-open-telnet-envuser nntp-telnet-user-name)
1805           (process-send-string proc (concat "open " "-l" nntp-telnet-user-name
1806                                             nntp-address "\n")))
1807          (t
1808           (process-send-string proc (concat "open " nntp-address "\n"))))
1809         (cond
1810          ((not nntp-open-telnet-envuser)
1811           (nntp-wait-for-string "^\r*.?login:")
1812           (process-send-string
1813            proc (concat
1814                  (or nntp-telnet-user-name
1815                      (setq nntp-telnet-user-name (read-string "login: ")))
1816                  "\n"))))
1817         (nntp-wait-for-string "^\r*.?password:")
1818         (process-send-string
1819          proc (concat
1820                (or nntp-telnet-passwd
1821                    (setq nntp-telnet-passwd
1822                          (read-passwd "Password: ")))
1823                "\n"))
1824         (nntp-wait-for-string nntp-telnet-shell-prompt)
1825         (process-send-string
1826          proc (concat (mapconcat 'identity nntp-telnet-parameters " ") "\n"))
1827         (nntp-wait-for-string "^\r*20[01]")
1828         (beginning-of-line)
1829         (delete-region (point-min) (point))
1830         (process-send-string proc "\^]")
1831         (nntp-wait-for-string "^r?telnet")
1832         (process-send-string proc "mode character\n")
1833         (accept-process-output proc 1)
1834         (sit-for 1)
1835         (goto-char (point-min))
1836         (forward-line 1)
1837         (delete-region (point) (point-max)))
1838       proc)))
1839
1840 (defun nntp-open-rlogin (buffer)
1841   "Open a connection to SERVER using rsh."
1842   (let ((proc (if nntp-rlogin-user-name
1843                   (as-binary-process
1844                    (apply 'start-process
1845                           "nntpd" buffer nntp-rlogin-program
1846                           nntp-address "-l" nntp-rlogin-user-name
1847                           nntp-rlogin-parameters))
1848                 (as-binary-process
1849                  (apply 'start-process
1850                         "nntpd" buffer nntp-rlogin-program nntp-address
1851                         nntp-rlogin-parameters)))))
1852     (save-excursion
1853       (set-buffer buffer)
1854       (nntp-wait-for-string "^\r*20[01]")
1855       (beginning-of-line)
1856       (delete-region (point-min) (point))
1857       proc)))
1858
1859
1860 ;; ==========================================================================
1861 ;; Replacements for the nntp-open-* functions -- drv
1862 ;; ==========================================================================
1863
1864 (defun nntp-open-telnet-stream (buffer)
1865   "Open a nntp connection by telnet'ing the news server.
1866
1867 Please refer to the following variables to customize the connection:
1868 - `nntp-pre-command',
1869 - `nntp-telnet-command',
1870 - `nntp-telnet-switches',
1871 - `nntp-address',
1872 - `nntp-port-number',
1873 - `nntp-end-of-line'."
1874   (let ((command `(,nntp-telnet-command
1875                    ,@nntp-telnet-switches
1876                    ,nntp-address ,nntp-port-number))
1877         proc)
1878     (and nntp-pre-command
1879          (push nntp-pre-command command))
1880     (setq proc (as-binary-process
1881                 (apply 'start-process "nntpd" buffer command)))
1882     (save-excursion
1883       (set-buffer buffer)
1884       (nntp-wait-for-string "^\r*20[01]")
1885       (beginning-of-line)
1886       (delete-region (point-min) (point))
1887       proc)))
1888
1889 (defun nntp-open-via-rlogin-and-telnet (buffer)
1890   "Open a connection to an nntp server through an intermediate host.
1891 First rlogin to the remote host, and then telnet the real news server
1892 from there.
1893
1894 Please refer to the following variables to customize the connection:
1895 - `nntp-pre-command',
1896 - `nntp-via-rlogin-command',
1897 - `nntp-via-rlogin-command-switches',
1898 - `nntp-via-user-name',
1899 - `nntp-via-address',
1900 - `nntp-telnet-command',
1901 - `nntp-telnet-switches',
1902 - `nntp-address',
1903 - `nntp-port-number',
1904 - `nntp-end-of-line'."
1905   (let ((command `(,nntp-via-address
1906                    ,nntp-telnet-command
1907                    ,@nntp-telnet-switches))
1908         proc)
1909     (when nntp-via-user-name
1910       (setq command `("-l" ,nntp-via-user-name ,@command)))
1911     (when nntp-via-rlogin-command-switches
1912       (setq command (append nntp-via-rlogin-command-switches command)))
1913     (push nntp-via-rlogin-command command)
1914     (and nntp-pre-command
1915          (push nntp-pre-command command))
1916     (setq proc (as-binary-process
1917                 (apply 'start-process "nntpd" buffer command)))
1918     (save-excursion
1919       (set-buffer buffer)
1920       (nntp-wait-for-string "^r?telnet")
1921       (process-send-string proc (concat "open " nntp-address
1922                                         " " nntp-port-number "\n"))
1923       (nntp-wait-for-string "^\r*20[01]")
1924       (beginning-of-line)
1925       (delete-region (point-min) (point))
1926       (process-send-string proc "\^]")
1927       (nntp-wait-for-string "^r?telnet")
1928       (process-send-string proc "mode character\n")
1929       (accept-process-output proc 1)
1930       (sit-for 1)
1931       (goto-char (point-min))
1932       (forward-line 1)
1933       (delete-region (point) (point-max)))
1934     proc))
1935
1936 (defun nntp-open-via-rlogin-and-netcat (buffer)
1937   "Open a connection to an nntp server through an intermediate host.
1938 First rlogin to the remote host, and then connect to the real news
1939 server from there using the netcat command.
1940
1941 Please refer to the following variables to customize the connection:
1942 - `nntp-pre-command',
1943 - `nntp-via-rlogin-command',
1944 - `nntp-via-rlogin-command-switches',
1945 - `nntp-via-user-name',
1946 - `nntp-via-address',
1947 - `nntp-via-netcat-command',
1948 - `nntp-via-netcat-switches',
1949 - `nntp-address',
1950 - `nntp-port-number',
1951 - `nntp-end-of-line'."
1952   (let ((command `(,@(when nntp-pre-command
1953                        (list nntp-pre-command))
1954                    ,nntp-via-rlogin-command
1955                    ,@(when nntp-via-rlogin-command-switches
1956                        nntp-via-rlogin-command-switches)
1957                    ,@(when nntp-via-user-name
1958                        (list "-l" nntp-via-user-name))
1959                    ,nntp-via-address
1960                    ,nntp-via-netcat-command
1961                    ,@nntp-via-netcat-switches
1962                    ,nntp-address
1963                    ,nntp-port-number)))
1964     (apply 'start-process "nntpd" buffer command)))
1965
1966 (defun nntp-open-via-telnet-and-telnet (buffer)
1967   "Open a connection to an nntp server through an intermediate host.
1968 First telnet the remote host, and then telnet the real news server
1969 from there.
1970
1971 Please refer to the following variables to customize the connection:
1972 - `nntp-pre-command',
1973 - `nntp-via-telnet-command',
1974 - `nntp-via-telnet-switches',
1975 - `nntp-via-address',
1976 - `nntp-via-envuser',
1977 - `nntp-via-user-name',
1978 - `nntp-via-user-password',
1979 - `nntp-via-shell-prompt',
1980 - `nntp-telnet-command',
1981 - `nntp-telnet-switches',
1982 - `nntp-address',
1983 - `nntp-port-number',
1984 - `nntp-end-of-line'."
1985   (save-excursion
1986     (set-buffer buffer)
1987     (erase-buffer)
1988     (let ((command `(,nntp-via-telnet-command ,@nntp-via-telnet-switches))
1989           (case-fold-search t)
1990           proc)
1991       (and nntp-pre-command (push nntp-pre-command command))
1992       (setq proc (as-binary-process
1993                   (apply 'start-process "nntpd" buffer command)))
1994       (when (memq (process-status proc) '(open run))
1995         (nntp-wait-for-string "^r?telnet")
1996         (process-send-string proc "set escape \^X\n")
1997         (cond
1998          ((and nntp-via-envuser nntp-via-user-name)
1999           (process-send-string proc (concat "open " "-l" nntp-via-user-name
2000                                             nntp-via-address "\n")))
2001          (t
2002           (process-send-string proc (concat "open " nntp-via-address
2003                                             "\n"))))
2004         (when (not nntp-via-envuser)
2005           (nntp-wait-for-string "^\r*.?login:")
2006           (process-send-string proc
2007                                (concat
2008                                 (or nntp-via-user-name
2009                                     (setq nntp-via-user-name
2010                                           (read-string "login: ")))
2011                                 "\n")))
2012         (nntp-wait-for-string "^\r*.?password:")
2013         (process-send-string proc
2014                              (concat
2015                               (or nntp-via-user-password
2016                                   (setq nntp-via-user-password
2017                                         (read-passwd "Password: ")))
2018                               "\n"))
2019         (nntp-wait-for-string nntp-via-shell-prompt)
2020         (let ((real-telnet-command `("exec"
2021                                      ,nntp-telnet-command
2022                                      ,@nntp-telnet-switches
2023                                      ,nntp-address
2024                                      ,nntp-port-number)))
2025           (process-send-string proc
2026                                (concat (mapconcat 'identity
2027                                                   real-telnet-command " ")
2028                                        "\n")))
2029         (nntp-wait-for-string "^\r*20[01]")
2030         (beginning-of-line)
2031         (delete-region (point-min) (point))
2032         (process-send-string proc "\^]")
2033         (nntp-wait-for-string "^r?telnet")
2034         (process-send-string proc "mode character\n")
2035         (accept-process-output proc 1)
2036         (sit-for 1)
2037         (goto-char (point-min))
2038         (forward-line 1)
2039         (delete-region (point) (point-max)))
2040       proc)))
2041
2042 ;; Marks handling
2043
2044 (defun nntp-marks-directory (server)
2045   (expand-file-name server nntp-marks-directory))
2046
2047 (defun nntp-possibly-create-directory (group server)
2048   (let ((dir (nnmail-group-pathname
2049               group (nntp-marks-directory server))))
2050     (unless (file-exists-p dir)
2051       (make-directory (directory-file-name dir) t)
2052       (nnheader-message 5 "Creating nntp marks directory %s" dir))))
2053
2054 (defun nntp-marks-changed-p (group server)
2055   (let ((file (expand-file-name
2056                nntp-marks-file-name
2057                (nnmail-group-pathname
2058                 group (nntp-marks-directory server)))))
2059     (if (null (gnus-gethash file nntp-marks-modtime))
2060         t ;; never looked at marks file, assume it has changed
2061       (not (equal (gnus-gethash file nntp-marks-modtime)
2062                   (nth 5 (file-attributes file)))))))
2063
2064 (defun nntp-save-marks (group server)
2065   (let ((file-name-coding-system nnmail-pathname-coding-system)
2066         (file (expand-file-name
2067                nntp-marks-file-name
2068                (nnmail-group-pathname
2069                 group (nntp-marks-directory server)))))
2070     (condition-case err
2071         (progn
2072           (nntp-possibly-create-directory group server)
2073           (with-temp-file file
2074             (erase-buffer)
2075             (gnus-prin1 nntp-marks)
2076             (insert "\n"))
2077           (gnus-sethash file
2078                         (nth 5 (file-attributes file))
2079                         nntp-marks-modtime))
2080       (error (or (gnus-yes-or-no-p
2081                   (format "Could not write to %s (%s).  Continue? " file err))
2082                  (error "Cannot write to %s (%s)" file err))))))
2083
2084 (defun nntp-open-marks (group server)
2085   (let ((file (expand-file-name
2086                nntp-marks-file-name
2087                (nnmail-group-pathname
2088                 group (nntp-marks-directory server)))))
2089     (if (file-exists-p file)
2090         (condition-case err
2091             (with-temp-buffer
2092               (gnus-sethash file (nth 5 (file-attributes file))
2093                             nntp-marks-modtime)
2094               (nnheader-insert-file-contents file)
2095               (setq nntp-marks (read (current-buffer)))
2096               (dolist (el gnus-article-unpropagated-mark-lists)
2097                 (setq nntp-marks (gnus-remassoc el nntp-marks))))
2098           (error (or (gnus-yes-or-no-p
2099                       (format "Error reading nntp marks file %s (%s).  Continuing will use marks from .newsrc.eld.  Continue? " file err))
2100                      (error "Cannot read nntp marks file %s (%s)" file err))))
2101       ;; User didn't have a .marks file.  Probably first time
2102       ;; user of the .marks stuff.  Bootstrap it from .newsrc.eld.
2103       (let ((info (gnus-get-info
2104                    (gnus-group-prefixed-name
2105                     group
2106                     (gnus-server-to-method (format "nntp:%s" server))))))
2107         (nnheader-message 7 "Bootstrapping marks for %s..." group)
2108         (setq nntp-marks (gnus-info-marks info))
2109         (push (cons 'read (gnus-info-read info)) nntp-marks)
2110         (dolist (el gnus-article-unpropagated-mark-lists)
2111           (setq nntp-marks (gnus-remassoc el nntp-marks)))
2112         (nntp-save-marks group server)
2113         (nnheader-message 7 "Bootstrapping marks for %s...done" group)))))
2114
2115 (provide 'nntp)
2116
2117 ;;; nntp.el ends here