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