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