X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnntp.el;h=a8ffc6576cafef4b094f2c77bee43d93b57b1e89;hb=cc52ad34d2922b013fd8026d0728617261979da6;hp=6504f05c9d28f33e03220e8ea7d287d3762e7933;hpb=184ab343047ce20af5af38d2163f7d0a3e3bd0d5;p=gnus diff --git a/lisp/nntp.el b/lisp/nntp.el index 6504f05c9..a8ffc6576 100644 --- a/lisp/nntp.el +++ b/lisp/nntp.el @@ -1,8 +1,7 @@ ;;; nntp.el --- nntp access for Gnus -;; Copyright (C) 1987, 1988, 1989, 1990, 1992, 1993, 1994, 1995, 1996, -;; 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1987-1990, 1992-1998, 2000-2011 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -28,20 +27,23 @@ ;; For Emacs <22.2 and XEmacs. (eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) + ;; In Emacs 24, `open-protocol-stream' is an autoloaded alias for + ;; `make-network-stream'. + (unless (fboundp 'open-protocol-stream) + (require 'proto-stream))) (require 'nnheader) (require 'nnoo) (require 'gnus-util) (require 'gnus) -(require 'proto-stream) (require 'gnus-group) ;; gnus-group-name-charset (nnoo-declare nntp) (eval-when-compile (require 'cl)) -(autoload 'auth-source-user-or-password "auth-source") +(autoload 'auth-source-search "auth-source") (defgroup nntp nil "NNTP access for Gnus." @@ -77,25 +79,27 @@ to innd, you could say something like: You probably don't want to do that, though.") (defvoo nntp-open-connection-function 'nntp-open-network-stream - "*Function used for connecting to a remote system. -It will be called with the buffer to output in as argument. - -Currently, five such functions are provided (please refer to their -respective doc string for more information), three of them establishing -direct connections to the nntp server, and two of them using an indirect -host. - -Direct connections: -- `nntp-open-network-stream' (the default), -- `nntp-open-ssl-stream', -- `nntp-open-tls-stream', -- `nntp-open-netcat-stream'. -- `nntp-open-telnet-stream'. - -Indirect connections: -- `nntp-open-via-rlogin-and-netcat', -- `nntp-open-via-rlogin-and-telnet', -- `nntp-open-via-telnet-and-telnet'.") + "Method for connecting to a remote system. +It should be a function, which is called with the output buffer +as its single argument, or one of the following special values: + +- `nntp-open-network-stream' specifies a network connection, + upgrading to a TLS connection via STARTTLS if possible. +- `nntp-open-plain-stream' specifies an unencrypted network + connection (no STARTTLS upgrade is attempted). +- `nntp-open-ssl-stream' or `nntp-open-tls-stream' specify a TLS + network connection. + +Apart from the above special values, valid functions are as +follows; please refer to their respective doc string for more +information. +For direct connections: +- `nntp-open-netcat-stream' +- `nntp-open-telnet-stream' +For indirect connections: +- `nntp-open-via-rlogin-and-netcat' +- `nntp-open-via-rlogin-and-telnet' +- `nntp-open-via-telnet-and-telnet'") (defvoo nntp-never-echoes-commands nil "*Non-nil means the nntp server never echoes commands. @@ -360,19 +364,6 @@ be restored and the command retried." (throw 'nntp-with-open-group-error t)) -(defmacro nntp-insert-buffer-substring (buffer &optional start end) - "Copy string from unibyte buffer to multibyte current buffer." - (if (featurep 'xemacs) - `(insert-buffer-substring ,buffer ,start ,end) - `(if enable-multibyte-characters - (insert (with-current-buffer ,buffer - (mm-string-to-multibyte - ,(if (or start end) - `(buffer-substring (or ,start (point-min)) - (or ,end (point-max))) - '(buffer-string))))) - (insert-buffer-substring ,buffer ,start ,end)))) - (defmacro nntp-copy-to-buffer (buffer start end) "Copy string from unibyte current buffer to multibyte buffer." (if (featurep 'xemacs) @@ -398,7 +389,8 @@ be restored and the command retried." (cond ((looking-at "480") (nntp-handle-authinfo process)) ((looking-at "482") - (nnheader-report 'nntp (get 'nntp-authinfo-rejected 'error-message)) + (nnheader-report 'nntp "%s" + (get 'nntp-authinfo-rejected 'error-message)) (signal 'nntp-authinfo-rejected nil)) ((looking-at "^.*\n") (delete-region (point) (progn (forward-line 1) (point))))) @@ -429,7 +421,7 @@ be restored and the command retried." (unless discard (with-current-buffer buffer (goto-char (point-max)) - (nntp-insert-buffer-substring (process-buffer process)) + (nnheader-insert-buffer-substring (process-buffer process)) ;; Nix out "nntp reading...." message. (when nntp-have-messaged (setq nntp-have-messaged nil) @@ -772,6 +764,72 @@ command whose response triggered the error." (nntp-copy-to-buffer nntp-server-buffer (point-min) (point-max)) 'headers))))) +(deffoo nntp-retrieve-group-data-early (server infos) + "Retrieve group info on INFOS." + (nntp-with-open-group nil server + (when (nntp-find-connection-buffer nntp-server-buffer) + ;; The first time this is run, this variable is `try'. So we + ;; try. + (when (eq nntp-server-list-active-group 'try) + (nntp-try-list-active + (gnus-group-real-name (gnus-info-group (car infos))))) + (with-current-buffer (nntp-find-connection-buffer nntp-server-buffer) + (erase-buffer) + (let ((nntp-inhibit-erase t) + (command (if nntp-server-list-active-group + "LIST ACTIVE" "GROUP"))) + (dolist (info infos) + (nntp-send-command + nil command (gnus-group-real-name (gnus-info-group info))))) + (length infos))))) + +(deffoo nntp-finish-retrieve-group-infos (server infos count) + (nntp-with-open-group nil server + (let ((buf (nntp-find-connection-buffer nntp-server-buffer)) + (method (gnus-find-method-for-group + (gnus-info-group (car infos)) + (car infos))) + (received 0) + (last-point 1)) + (when (and buf + count) + (with-current-buffer buf + (while (and (gnus-buffer-live-p buf) + (progn + (goto-char last-point) + ;; Count replies. + (while (re-search-forward + (if nntp-server-list-active-group + "^[.]" + "^[0-9]") + nil t) + (incf received)) + (setq last-point (point)) + (< received count))) + (nntp-accept-response)) + ;; We now have all the entries. Remove CRs. + (nnheader-strip-cr) + (if (not nntp-server-list-active-group) + (progn + (nntp-copy-to-buffer nntp-server-buffer + (point-min) (point-max)) + (gnus-groups-to-gnus-format method gnus-active-hashtb t)) + ;; We have read active entries, so we just delete the + ;; superfluous gunk. + (goto-char (point-min)) + (while (re-search-forward "^[.2-5]" nil t) + (delete-region (match-beginning 0) + (progn (forward-line 1) (point)))) + (nntp-copy-to-buffer nntp-server-buffer (point-min) (point-max)) + (with-current-buffer nntp-server-buffer + (gnus-active-to-gnus-format + ;; Kludge to use the extended method name if you have + ;; an extended one. + (if (consp (gnus-info-method (car infos))) + (gnus-info-method (car infos)) + method) + gnus-active-hashtb nil t)))))))) + (deffoo nntp-retrieve-groups (groups &optional server) "Retrieve group info on GROUPS." (nntp-with-open-group @@ -925,7 +983,7 @@ command whose response triggered the error." (narrow-to-region (setq point (goto-char (point-max))) (progn - (nntp-insert-buffer-substring buf last-point (cdr entry)) + (nnheader-insert-buffer-substring buf last-point (cdr entry)) (point-max))) (setq last-point (cdr entry)) (nntp-decode-text) @@ -957,16 +1015,15 @@ command whose response triggered the error." (deffoo nntp-request-article (article &optional group server buffer command) (nntp-with-open-group - group server + group server (when (nntp-send-command-and-decode "\r?\n\\.\r?\n" "ARTICLE" (if (numberp article) (int-to-string article) article)) - (if (and buffer - (not (equal buffer nntp-server-buffer))) - (with-current-buffer nntp-server-buffer - (copy-to-buffer buffer (point-min) (point-max)) - (nntp-find-group-and-number group)) - (nntp-find-group-and-number group))))) + (when (and buffer + (not (equal buffer nntp-server-buffer))) + (with-current-buffer nntp-server-buffer + (copy-to-buffer buffer (point-min) (point-max)))) + (nntp-find-group-and-number group)))) (deffoo nntp-request-head (article &optional group server) (nntp-with-open-group @@ -1170,11 +1227,20 @@ If SEND-IF-FORCE, only send authinfo to the server if the (require 'netrc) (let* ((list (netrc-parse nntp-authinfo-file)) (alist (netrc-machine list nntp-address "nntp")) - (force (or (netrc-get alist "force") nntp-authinfo-force)) - (auth-info - (auth-source-user-or-password '("login" "password") nntp-address "nntp")) - (auth-user (nth 0 auth-info)) - (auth-passwd (nth 1 auth-info)) + (auth-info + (nth 0 (auth-source-search :max 1 + ;; TODO: allow the virtual server name too + :host nntp-address + :port '("119" "nntp")))) + (auth-user (plist-get auth-info :user)) + (auth-force (plist-get auth-info :force)) + (auth-passwd (plist-get auth-info :secret)) + (auth-passwd (if (functionp auth-passwd) + (funcall auth-passwd) + auth-passwd)) + (force (or (netrc-get alist "force") + nntp-authinfo-force + auth-force)) (user (or ;; this is preferred to netrc-* auth-user @@ -1266,24 +1332,25 @@ password contained in '~/.nntp-authinfo'." (let ((coding-system-for-read nntp-coding-system-for-read) (coding-system-for-write nntp-coding-system-for-write) (map '((nntp-open-network-stream network) + (network-only plain) ; compat + (nntp-open-plain-stream plain) (nntp-open-ssl-stream tls) (nntp-open-tls-stream tls)))) (if (assoc nntp-open-connection-function map) - (car (open-protocol-stream - "nntpd" pbuffer nntp-address nntp-port-number - :type (cadr - (assoc nntp-open-connection-function map)) - :end-of-command "^\\([2345]\\|[.]\\).*\n" - :capability-command "CAPABILITIES\r\n" - :success "^3" - :starttls-function - (lambda (capabilities) - (if (not (string-match "STARTTLS" capabilities)) - nil - "STARTTLS\r\n")))) + (open-protocol-stream + "nntpd" pbuffer nntp-address nntp-port-number + :type (cadr (assoc nntp-open-connection-function map)) + :end-of-command "^\\([2345]\\|[.]\\).*\n" + :capability-command "CAPABILITIES\r\n" + :success "^3" + :starttls-function + (lambda (capabilities) + (if (not (string-match "STARTTLS" capabilities)) + nil + "STARTTLS\r\n"))) (funcall nntp-open-connection-function pbuffer))) (error - (nnheader-report 'nntp "%s" err)) + (nnheader-report 'nntp ">>> %s" err)) (quit (message "Quit opening connection to %s" nntp-address) (nntp-kill-buffer pbuffer) @@ -1291,10 +1358,19 @@ password contained in '~/.nntp-authinfo'." nil)))) (when timer (nnheader-cancel-timer timer)) + (when (and process + (not (memq (process-status process) '(open run)))) + (setq process nil)) (unless process (nntp-kill-buffer pbuffer)) (when (and (buffer-name pbuffer) process) + (when (and (fboundp 'set-network-process-option) ;; Unavailable in XEmacs. + (fboundp 'process-type) ;; Emacs 22 doesn't provide it. + (eq (process-type process) 'network)) + ;; Use TCP-keepalive so that connections that pass through a NAT router + ;; don't hang when left idle. + (set-network-process-option process :keepalive t)) (gnus-set-process-query-on-exit-flag process nil) (if (and (nntp-wait-for process "^2.*\n" buffer nil t) (memq (process-status process) '(open run))) @@ -1392,7 +1468,7 @@ password contained in '~/.nntp-authinfo'." (goto-char (point-max)) (save-restriction (narrow-to-region (point) (point)) - (nntp-insert-buffer-substring buf start) + (nnheader-insert-buffer-substring buf start) (when decode (nntp-decode-text)))))) ;; report it. @@ -1411,7 +1487,7 @@ password contained in '~/.nntp-authinfo'." (let ((message (buffer-string))) (while (string-match "[\r\n]+" message) (setq message (replace-match " " t t message))) - (nnheader-report 'nntp message) + (nnheader-report 'nntp "%s" message) message)) (defun nntp-accept-process-output (process) @@ -1597,7 +1673,7 @@ password contained in '~/.nntp-authinfo'." ;; Some nntp servers seem to have an extension to the XOVER ;; extension. On these servers, requesting an article range - ;; preceeding the active range does not return an error as + ;; preceding the active range does not return an error as ;; specified in the RFC. What we instead get is the NOV entry ;; for the first available article. Obviously, a client can ;; use that entry to avoid making unnecessary requests. The @@ -1620,7 +1696,7 @@ password contained in '~/.nntp-authinfo'." (when in-process-buffer-p (set-buffer buf) (goto-char (point-max)) - (nntp-insert-buffer-substring process-buffer) + (nnheader-insert-buffer-substring process-buffer) (set-buffer process-buffer) (erase-buffer) (set-buffer buf))