;;; nntp.el --- nntp access for Gnus
-;; Copyright (C) 1987, 1988, 1989, 1990, 1992, 1993, 1994, 1995, 1996,
-;; 1997, 1998, 2000, 2001, 2002, 2003, 2004 Free Software Foundation, Inc.
+;; Copyright (C) 1987, 1988, 1989, 1990, 1992, 1993,
+;; 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002,
+;; 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published
-;; by the Free Software Foundation; either version 2, or (at your
+;; by the Free Software Foundation; either version 3, or (at your
;; option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful, but
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston,
+;; MA 02110-1301, USA.
;;; Commentary:
(require 'nnoo)
(require 'gnus-util)
(require 'gnus)
+(require 'gnus-group) ;; gnus-group-name-charset
(nnoo-declare nntp)
(eval-when-compile (require 'cl))
+(defgroup nntp nil
+ "NNTP access for Gnus."
+ :group 'gnus)
+
(defvoo nntp-address nil
"Address of the physical nntp server.")
- `nntp-open-via-rlogin-and-netcat',
- `nntp-open-via-telnet-and-telnet'.")
+(defvoo nntp-never-echoes-commands nil
+ "*Non-nil means the nntp server never echoes commands.
+It is reported that some nntps server doesn't echo commands. So, you
+may want to set this to non-nil in the method for such a server setting
+`nntp-open-connection-function' to `nntp-open-ssl-stream' for example.
+Note that the `nntp-open-connection-functions-never-echo-commands'
+variable overrides the nil value of this variable.")
+
+(defvoo nntp-open-connection-functions-never-echo-commands
+ '(nntp-open-network-stream)
+ "*List of functions that never echo commands.
+Add or set a function which you set to `nntp-open-connection-function'
+to this list if it does not echo commands. Note that a non-nil value
+of the `nntp-never-echoes-commands' variable overrides this variable.")
+
(defvoo nntp-pre-command nil
"*Pre-command to use with the various nntp-open-via-* methods.
This is where you would put \"runsocks\" or stuff like that.")
(defvoo nntp-end-of-line "\r\n"
"*String to use on the end of lines when talking to the NNTP server.
-This is \"\\r\\n\" by default, but should be \"\\n\" when using and
-indirect telnet connection method (nntp-open-via-*-and-telnet).")
+This is \"\\r\\n\" by default, but should be \"\\n\" when using an indirect
+connection method (nntp-open-via-*).")
(defvoo nntp-via-rlogin-command "rsh"
"*Rlogin command used to connect to an intermediate host.
If the gap between two consecutive articles is bigger than this
variable, split the XOVER request into two requests.")
+(defvoo nntp-xref-number-is-evil nil
+ "*If non-nil, Gnus never trusts article numbers in the Xref header.
+Some news servers, e.g., ones running Diablo, run multiple engines
+having the same articles but article numbers are not kept synchronized
+between them. If you connect to such a server, set this to a non-nil
+value, and Gnus never uses article numbers (that appear in the Xref
+header and vary by which engine is chosen) to refer to articles.")
+
(defvoo nntp-prepare-server-hook nil
"*Hook run before a server is opened.
If can be used to set up a server remotely, for instance. Say you
server there that you can connect to. See also
`nntp-open-connection-function'")
-(defvoo nntp-warn-about-losing-connection t
- "*If non-nil, beep when a server closes connection.")
-
(defvoo nntp-coding-system-for-read 'binary
"*Coding system to read from NNTP.")
;; Marks
(defvoo nntp-marks-is-evil nil
- "*If non-nil, GNus will never generate and use marks file for nntp groups.
+ "*If non-nil, Gnus will never generate and use marks file for nntp groups.
See `nnml-marks-is-evil' for more information.")
(defvoo nntp-marks-file-name ".marks")
(defcustom nntp-marks-directory
(nnheader-concat gnus-directory "marks/")
"*The directory where marks for nntp groups will be stored."
- :group 'gnus
+ :group 'nntp
:type 'directory)
(defcustom nntp-authinfo-file "~/.authinfo"
".netrc-like file that holds nntp authinfo passwords."
+ :group 'nntp
:type
'(choice file
(repeat :tag "Entries"
(defvoo nntp-last-command nil)
(defvoo nntp-authinfo-password nil)
(defvoo nntp-authinfo-user nil)
+(defvoo nntp-authinfo-force nil)
(defvar nntp-connection-list nil)
(defvar nntp-async-timer nil)
(defvar nntp-async-process-list nil)
-(defvar nntp-ssl-program
+(defvar nntp-ssl-program
"openssl s_client -quiet -ssl3 -connect %s:%p"
"A string containing commands for SSL connections.
Within a string, %s is replaced with the server address and %p with
port number on server. The program should accept IMAP commands on
stdin and return responses to stdout.")
+(defvar nntp-authinfo-rejected nil
+"A custom error condition used to report 'Authentication Rejected' errors.
+Condition handlers that match just this condition ensure that the nntp
+backend doesn't catch this error.")
+(put 'nntp-authinfo-rejected 'error-conditions '(error nntp-authinfo-rejected))
+(put 'nntp-authinfo-rejected 'error-message "Authorization Rejected")
+
\f
;;; Internal functions.
(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)
+ `(copy-to-buffer ,buffer ,start ,end)
+ `(let ((string (buffer-substring ,start ,end)))
+ (with-current-buffer ,buffer
+ (erase-buffer)
+ (insert (if enable-multibyte-characters
+ (mm-string-to-multibyte string)
+ string))
+ (goto-char (point-min))
+ nil))))
+
(defsubst nntp-wait-for (process wait-for buffer &optional decode discard)
"Wait for WAIT-FOR to arrive from PROCESS."
+
(save-excursion
(set-buffer (process-buffer process))
(goto-char (point-min))
+
(while (and (or (not (memq (char-after (point)) '(?2 ?3 ?4 ?5)))
- (looking-at "480"))
+ (looking-at "48[02]"))
(memq (process-status process) '(open run)))
- (when (looking-at "480")
- (nntp-handle-authinfo process))
- (when (looking-at "^.*\n")
- (delete-region (point) (progn (forward-line 1) (point))))
+ (cond ((looking-at "480")
+ (nntp-handle-authinfo process))
+ ((looking-at "482")
+ (nnheader-report 'nntp (get 'nntp-authinfo-rejected 'error-message))
+ (signal 'nntp-authinfo-rejected nil))
+ ((looking-at "^.*\n")
+ (delete-region (point) (progn (forward-line 1) (point)))))
(nntp-accept-process-output process)
(goto-char (point-min)))
(prog1
(save-excursion
(set-buffer buffer)
(goto-char (point-max))
- (insert-buffer-substring (process-buffer process))
+ (nntp-insert-buffer-substring (process-buffer process))
;; Nix out "nntp reading...." message.
(when nntp-have-messaged
(setq nntp-have-messaged nil)
(wait-for
(nntp-wait-for process wait-for buffer decode))
(t t)))
+ (nntp-authinfo-rejected
+ (signal 'nntp-authinfo-rejected (cdr err)))
(error
(nnheader-report 'nntp "Couldn't open connection to %s: %s"
address err))
nntp-server-buffer
wait-for nnheader-callback-function)
;; If nothing to wait for, still remove possibly echo'ed commands.
- ;; We don't have echos if nntp-open-connection-function
- ;; is `nntp-open-network-stream', so we skip this in that case.
+ ;; We don't have echoes if `nntp-never-echoes-commands' is non-nil
+ ;; or the value of `nntp-open-connection-function' is in
+ ;; `nntp-open-connection-functions-never-echo-commands', so we
+ ;; skip this in that cases.
(unless (or wait-for
- (equal nntp-open-connection-function
- 'nntp-open-network-stream))
+ nntp-never-echoes-commands
+ (memq
+ nntp-open-connection-function
+ nntp-open-connection-functions-never-echo-commands))
(nntp-accept-response)
(save-excursion
(set-buffer buffer)
(goto-char pos)
(if (looking-at (regexp-quote command))
(delete-region pos (progn (forward-line 1)
- (point-at-bol))))
- )))
+ (point-at-bol)))))))
(nnheader-report 'nntp "Couldn't open connection to %s."
nntp-address))))
;; a line with only a "." on it.
((eq (char-after) ?2)
(if (re-search-forward "\n\\.\r?\n" nil t)
- t
+ (progn
+ ;; Some broken news servers add another dot at the end.
+ ;; Protect against inflooping there.
+ (while (looking-at "^\\.\r?\n")
+ (forward-line 1))
+ t)
nil))
;; A result that starts with a 3xx or 4xx code is terminated
;; by a newline.
nntp-server-buffer))
(buffer (and process
(process-buffer process))))
- ;; When I an able to identify the
+ ;; When I am able to identify the
;; connection to the server AND I've
;; received NO reponse for
;; nntp-connection-timeout seconds.
(condition-case nil
(progn ,@forms)
(quit
- (nntp-close-server)
+ (unless debug-on-quit
+ (nntp-close-server))
(signal 'quit nil))))
(when timer
(nnheader-cancel-timer timer)))
(nnheader-fold-continuation-lines)
;; Remove all "\r"'s.
(nnheader-strip-cr)
- (copy-to-buffer nntp-server-buffer (point-min) (point-max))
+ (nntp-copy-to-buffer nntp-server-buffer (point-min) (point-max))
'headers)))))
(deffoo nntp-retrieve-groups (groups &optional server)
(if (not nntp-server-list-active-group)
(progn
- (copy-to-buffer nntp-server-buffer (point-min) (point-max))
+ (nntp-copy-to-buffer nntp-server-buffer
+ (point-min) (point-max))
'group)
;; We have read active entries, so we just delete the
;; superfluous gunk.
(while (re-search-forward "^[.2-5]" nil t)
(delete-region (match-beginning 0)
(progn (forward-line 1) (point))))
- (copy-to-buffer nntp-server-buffer (point-min) (point-max))
+ (nntp-copy-to-buffer nntp-server-buffer (point-min) (point-max))
'active)))))))
(deffoo nntp-retrieve-articles (articles &optional group server)
(narrow-to-region
(setq point (goto-char (point-max)))
(progn
- (insert-buffer-substring buf last-point (cdr entry))
+ (nntp-insert-buffer-substring buf last-point (cdr entry))
(point-max)))
(setq last-point (cdr entry))
(nntp-decode-text)
(if (numberp article) (int-to-string article) article))))
(deffoo nntp-request-group (group &optional server dont-check)
- (nntp-with-open-group
+ (nntp-with-open-group
nil server
(when (nntp-send-command "^[245].*\n" "GROUP" group)
(let ((entry (nntp-find-connection-entry nntp-server-buffer)))
(deffoo nntp-request-update-info (group info &optional server)
(unless nntp-marks-is-evil
- (nntp-possibly-create-directory group server))
- (when (and (not nntp-marks-is-evil) (nntp-marks-changed-p group server))
- (nnheader-message 8 "Updating marks for %s..." group)
- (nntp-open-marks group server)
- ;; Update info using `nntp-marks'.
- (mapc (lambda (pred)
- (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists)
- (gnus-info-set-marks
- info
- (gnus-update-alist-soft
- (cdr pred)
- (cdr (assq (cdr pred) nntp-marks))
- (gnus-info-marks info))
- t)))
- gnus-article-mark-lists)
- (let ((seen (cdr (assq 'read nntp-marks))))
- (gnus-info-set-read info
- (if (and (integerp (car seen))
- (null (cdr seen)))
- (list (cons (car seen) (car seen)))
- seen)))
- (nnheader-message 8 "Updating marks for %s...done" group))
- info)
+ (nntp-possibly-create-directory group server)
+ (when (nntp-marks-changed-p group server)
+ (nnheader-message 8 "Updating marks for %s..." group)
+ (nntp-open-marks group server)
+ ;; Update info using `nntp-marks'.
+ (mapc (lambda (pred)
+ (unless (memq (cdr pred) gnus-article-unpropagated-mark-lists)
+ (gnus-info-set-marks
+ info
+ (gnus-update-alist-soft
+ (cdr pred)
+ (cdr (assq (cdr pred) nntp-marks))
+ (gnus-info-marks info))
+ t)))
+ gnus-article-mark-lists)
+ (let ((seen (cdr (assq 'read nntp-marks))))
+ (gnus-info-set-read info
+ (if (and (integerp (car seen))
+ (null (cdr seen)))
+ (list (cons (car seen) (car seen)))
+ seen)))
+ (nnheader-message 8 "Updating marks for %s...done" group)))
+ nil)
.authinfo file has the FORCE token."
(let* ((list (netrc-parse nntp-authinfo-file))
(alist (netrc-machine list nntp-address "nntp"))
- (force (netrc-get alist "force"))
+ (force (or (netrc-get alist "force") nntp-authinfo-force))
(user (or (netrc-get alist "login") nntp-authinfo-user))
(passwd (netrc-get alist "password")))
(when (or (not send-if-force)
(format " *server %s %s %s*"
nntp-address nntp-port-number
(gnus-buffer-exists-p buffer))))
- (mm-enable-multibyte)
+ (mm-disable-multibyte)
(set (make-local-variable 'after-change-functions) nil)
(set (make-local-variable 'nntp-process-wait-for) nil)
(set (make-local-variable 'nntp-process-callback) nil)
(funcall nntp-open-connection-function pbuffer))
(error nil)
(quit
- (message "Quit opening connection")
+ (message "Quit opening connection to %s" nntp-address)
(nntp-kill-buffer pbuffer)
(signal 'quit nil)
nil))))
(nntp-kill-buffer pbuffer))
(when (and (buffer-name pbuffer)
process)
- (process-kill-without-query process)
+ (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)))
(prog1
(defun nntp-open-network-stream (buffer)
(open-network-stream "nntpd" buffer nntp-address nntp-port-number))
-(autoload 'format-spec "format")
-(autoload 'format-spec-make "format")
-(autoload 'open-tls-stream "tls")
+(eval-and-compile
+ (autoload 'format-spec "format-spec")
+ (autoload 'format-spec-make "format-spec")
+ (autoload 'open-tls-stream "tls"))
(defun nntp-open-ssl-stream (buffer)
(let* ((process-connection-type nil)
- (proc (start-process "nntpd" buffer
+ (proc (start-process "nntpd" buffer
shell-file-name
shell-command-switch
- (format-spec nntp-ssl-program
+ (format-spec nntp-ssl-program
(format-spec-make
?s nntp-address
?p nntp-port-number)))))
- (process-kill-without-query proc)
+ (gnus-set-process-query-on-exit-flag proc nil)
(save-excursion
(set-buffer buffer)
(let ((nntp-connection-alist (list proc buffer nil)))
(defun nntp-open-tls-stream (buffer)
(let ((proc (open-tls-stream "nntpd" buffer nntp-address nntp-port-number)))
- (process-kill-without-query proc)
+ (gnus-set-process-query-on-exit-flag proc nil)
(save-excursion
(set-buffer buffer)
(let ((nntp-connection-alist (list proc buffer nil)))
"Find out what the name of the server we have connected to is."
;; Wait for the status string to arrive.
(setq nntp-server-type (buffer-string))
- (let ((alist nntp-server-action-alist)
- (case-fold-search t)
- entry)
+ (let ((case-fold-search t))
;; Run server-specific commands.
- (while alist
- (setq entry (pop alist))
+ (dolist (entry nntp-server-action-alist)
(when (string-match (car entry) nntp-server-type)
(if (and (listp (cadr entry))
(not (eq 'lambda (caadr entry))))
(goto-char (point-max))
(save-restriction
(narrow-to-region (point) (point))
- (insert-buffer-substring buf start)
+ (nntp-insert-buffer-substring buf start)
(when decode
(nntp-decode-text))))))
;; report it.
(defun nntp-accept-process-output (process)
"Wait for output from PROCESS and message some dots."
- (save-excursion
- (set-buffer (or (nntp-find-connection-buffer nntp-server-buffer)
- nntp-server-buffer))
+ (with-current-buffer (or (nntp-find-connection-buffer nntp-server-buffer)
+ nntp-server-buffer)
(let ((len (/ (buffer-size) 1024))
message-log-max)
(unless (< len 10)
(setq nntp-have-messaged t)
(nnheader-message 7 "nntp read: %dk" len)))
- (nnheader-accept-process-output process)
- ;; accept-process-output may update status of process to indicate
- ;; that the server has closed the connection. This MUST be
- ;; handled here as the buffer restored by the save-excursion may
- ;; be the process's former output buffer (i.e. now killed)
- (or (and process
- (memq (process-status process) '(open run)))
- (nntp-report "Server closed connection"))))
+ (prog1
+ (nnheader-accept-process-output process)
+ ;; accept-process-output may update status of process to indicate
+ ;; that the server has closed the connection. This MUST be
+ ;; handled here as the buffer restored by the save-excursion may
+ ;; be the process's former output buffer (i.e. now killed)
+ (or (and process
+ (memq (process-status process) '(open run)))
+ (nntp-report "Server closed connection")))))
(defun nntp-accept-response ()
"Wait for output from the process that outputs to BUFFER."
(when (<= count 1)
(goto-char (point-min))
(when (re-search-forward "^[0-9][0-9][0-9] .*\n\\([0-9]+\\)" nil t)
- (let ((low-limit (string-to-int
- (buffer-substring (match-beginning 1)
+ (let ((low-limit (string-to-number
+ (buffer-substring (match-beginning 1)
(match-end 1)))))
(while (and articles (<= (car articles) low-limit))
(setq articles (cdr articles))))))
(when in-process-buffer-p
(set-buffer buf)
(goto-char (point-max))
- (insert-buffer-substring process-buffer)
+ (nntp-insert-buffer-substring process-buffer)
(set-buffer process-buffer)
(erase-buffer)
(set-buffer buf))
;; article number. How... helpful.
(progn
(forward-line 1)
- (looking-at "[0-9]+\t...")) ; More text after number.
+ ;; More text after number, or a dot.
+ (looking-at "[0-9]+\t...\\|\\.\r?\n"))
(setq nntp-server-xover (car commands))))
(setq commands (cdr commands)))
;; If none of the commands worked, we disable XOVER.
(goto-char (point-min))
;; We first find the number by looking at the status line.
(let ((number (and (looking-at "2[0-9][0-9] +\\([0-9]+\\) ")
- (string-to-int
+ (string-to-number
(buffer-substring (match-beginning 1)
(match-end 1)))))
newsgroups xref)
(match-string 1 xref))
(t "")))
(cond
- ((and (setq xref (mail-fetch-field "xref"))
+ ((and (not nntp-xref-number-is-evil)
+ (setq xref (mail-fetch-field "xref"))
(string-match
(if group
(concat "\\(" (regexp-quote group) "\\):\\([0-9]+\\)")
"\\([^ :]+\\):\\([0-9]+\\)")
xref))
(setq group (match-string 1 xref)
- number (string-to-int (match-string 2 xref))))
+ number (string-to-number (match-string 2 xref))))
((and (setq newsgroups
(mail-fetch-field "newsgroups"))
(not (string-match "," newsgroups)))
(defun nntp-marks-directory (server)
(expand-file-name server nntp-marks-directory))
+(defvar nntp-server-to-method-cache nil
+ "Alist of servers and select methods.")
+
+(defun nntp-group-pathname (server group &optional file)
+ "Return an absolute file name of FILE for GROUP on SERVER."
+ (let ((method (cdr (assoc server nntp-server-to-method-cache))))
+ (unless method
+ (push (cons server (setq method (or (gnus-server-to-method server)
+ (gnus-find-method-for-group group))))
+ nntp-server-to-method-cache))
+ (nnmail-group-pathname
+ (mm-decode-coding-string group
+ (inline (gnus-group-name-charset method group)))
+ (nntp-marks-directory server)
+ file)))
+
(defun nntp-possibly-create-directory (group server)
- (let ((dir (nnmail-group-pathname
- group (nntp-marks-directory server))))
+ (let ((dir (nntp-group-pathname server group))
+ (file-name-coding-system nnmail-pathname-coding-system))
(unless (file-exists-p dir)
(make-directory (directory-file-name dir) t)
(nnheader-message 5 "Creating nntp marks directory %s" dir))))
+(eval-and-compile
+ (autoload 'time-less-p "time-date"))
+
(defun nntp-marks-changed-p (group server)
- (let ((file (expand-file-name
- nntp-marks-file-name
- (nnmail-group-pathname
- group (nntp-marks-directory server)))))
+ (let ((file (nntp-group-pathname server group nntp-marks-file-name))
+ (file-name-coding-system nnmail-pathname-coding-system))
(if (null (gnus-gethash file nntp-marks-modtime))
t ;; never looked at marks file, assume it has changed
- (not (equal (gnus-gethash file nntp-marks-modtime)
- (nth 5 (file-attributes file)))))))
+ (time-less-p (gnus-gethash file nntp-marks-modtime)
+ (nth 5 (file-attributes file))))))
(defun nntp-save-marks (group server)
(let ((file-name-coding-system nnmail-pathname-coding-system)
- (file (expand-file-name
- nntp-marks-file-name
- (nnmail-group-pathname
- group (nntp-marks-directory server)))))
+ (file (nntp-group-pathname server group nntp-marks-file-name)))
(condition-case err
(progn
(nntp-possibly-create-directory group server)
(error "Cannot write to %s (%s)" file err))))))
(defun nntp-open-marks (group server)
- (let ((file (expand-file-name
- nntp-marks-file-name
- (nnmail-group-pathname
- group (nntp-marks-directory server)))))
+ (let ((file (nntp-group-pathname server group nntp-marks-file-name))
+ (file-name-coding-system nnmail-pathname-coding-system))
(if (file-exists-p file)
(condition-case err
(with-temp-buffer
(let ((info (gnus-get-info
(gnus-group-prefixed-name
group
- (gnus-server-to-method (format "nntp:%s" server))))))
- (nnheader-message 7 "Bootstrapping marks for %s..." group)
+ (gnus-server-to-method (format "nntp:%s" server)))))
+ (decoded-name (mm-decode-coding-string
+ group
+ (gnus-group-name-charset
+ (gnus-server-to-method server) group))))
+ (nnheader-message 7 "Bootstrapping marks for %s..." decoded-name)
(setq nntp-marks (gnus-info-marks info))
(push (cons 'read (gnus-info-read info)) nntp-marks)
(dolist (el gnus-article-unpropagated-mark-lists)
(setq nntp-marks (gnus-remassoc el nntp-marks)))
(nntp-save-marks group server)
- (nnheader-message 7 "Bootstrapping marks for %s...done" group)))))
+ (nnheader-message 7 "Bootstrapping marks for %s...done"
+ decoded-name)))))
(provide 'nntp)
projects / gnus / blobdiff