X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnntp.el;h=58135a1e598086beeb7b8094c02f98e2d9cd3b7c;hb=74c3c92f78597749c0ff9a5911c0a42f83ba46dc;hp=c8f1d04d4d3fcf4afd05b54318eccc7285b54da5;hpb=8ea8c66caa7ea01e9284a6c25c1ebf619e6ece81;p=gnus diff --git a/lisp/nntp.el b/lisp/nntp.el index c8f1d04d4..58135a1e5 100644 --- a/lisp/nntp.el +++ b/lisp/nntp.el @@ -1,7 +1,7 @@ ;;; nntp.el --- nntp access for Gnus -;; Copyright (C) 1987-1990, 1992-1998, 2000-2011 -;; Free Software Foundation, Inc. +;; Copyright (C) 1987-1990, 1992-1998, 2000-2013 Free Software +;; Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -222,27 +222,6 @@ then use this hook to rsh to the remote machine and start a proxy NNTP server there that you can connect to. See also `nntp-open-connection-function'") -(defvoo nntp-coding-system-for-read 'binary - "*Coding system to read from NNTP.") - -(defvoo nntp-coding-system-for-write 'binary - "*Coding system to write to NNTP.") - -;; Marks -(defvoo nntp-marks-is-evil nil - "*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") -(defvoo nntp-marks nil) -(defvar nntp-marks-modtime (gnus-make-hashtable)) - -(defcustom nntp-marks-directory - (nnheader-concat gnus-directory "marks/") - "*The directory where marks for nntp groups will be stored." - :group 'nntp - :type 'directory) - (defcustom nntp-authinfo-file "~/.authinfo" ".netrc-like file that holds nntp authinfo passwords." :group 'nntp @@ -261,6 +240,8 @@ See `nnml-marks-is-evil' for more information.") (const :format "" "password") (string :format "Password: %v"))))))) +(make-obsolete 'nntp-authinfo-file nil "Emacs 24.1") + (defvoo nntp-connection-timeout nil @@ -279,6 +260,7 @@ update their active files often, this can help.") ;;; Internal variables. +(defvoo nntp-retrieval-in-progress nil) (defvar nntp-record-commands nil "*If non-nil, nntp will record all commands in the \"*nntp-log*\" buffer.") @@ -338,44 +320,29 @@ backend doesn't catch this error.") "Record the command STRING." (with-current-buffer (get-buffer-create "*nntp-log*") (goto-char (point-max)) - (let ((time (current-time))) - (insert (format-time-string "%Y%m%dT%H%M%S" time) - "." (format "%03d" (/ (nth 2 time) 1000)) - " " nntp-address " " string "\n")))) + (insert (format-time-string "%Y%m%dT%H%M%S.%3N") + " " nntp-address " " string "\n"))) + +(defvar nntp--report-1 nil) (defun nntp-report (&rest args) "Report an error from the nntp backend. The first string in ARGS can be a format string. For some commands, the failed command may be retried once before actually displaying the error report." + (if nntp--report-1 + (progn + ;; Throw out to nntp-with-open-group-error so that the connection may + ;; be restored and the command retried." + (when nntp-record-commands + (nntp-record-command "*** CONNECTION LOST ***")) + (throw 'nntp-with-open-group-error t)) - (when nntp-record-commands - (nntp-record-command "*** CALLED nntp-report ***")) - - (nnheader-report 'nntp args) + (when nntp-record-commands + (nntp-record-command "*** CALLED nntp-report ***")) - (apply 'error args)) + (nnheader-report 'nntp args) -(defun nntp-report-1 (&rest args) - "Throws out to nntp-with-open-group-error so that the connection may -be restored and the command retried." - - (when nntp-record-commands - (nntp-record-command "*** CONNECTION LOST ***")) - - (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)))) + (apply 'error args))) (defmacro nntp-copy-to-buffer (buffer start end) "Copy string from unibyte current buffer to multibyte buffer." @@ -434,7 +401,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) @@ -445,6 +412,9 @@ be restored and the command retried." (defun nntp-kill-buffer (buffer) (when (buffer-name buffer) + (let ((process (get-buffer-process buffer))) + (when process + (delete-process process))) (kill-buffer buffer) (nnheader-init-server-buffer))) @@ -642,10 +612,6 @@ be restored and the command retried." (t nil))) -(eval-when-compile - (defvar nntp-with-open-group-internal nil) - (defvar nntp-report-n nil)) - (defun nntp-with-open-group-function (-group -server -connectionless -bodyfun) "Protect against servers that don't like clients that keep idle connections opens. The problem being that these servers may either close a connection or @@ -656,9 +622,9 @@ connection timeouts (which may be several minutes) or `nntp-connection-timeout' has expired. When these occur `nntp-with-open-group', opens a new connection then re-issues the NNTP command whose response triggered the error." - (letf ((nntp-report-n (symbol-function 'nntp-report)) - ((symbol-function 'nntp-report) (symbol-function 'nntp-report-1)) - (nntp-with-open-group-internal nil)) + (let ((nntp-report-n nntp--report-1) + (nntp--report-1 t) + (nntp-with-open-group-internal nil)) (while (catch 'nntp-with-open-group-error ;; Open the connection to the server ;; NOTE: Existing connections are NOT tested. @@ -675,7 +641,7 @@ command whose response triggered the error." (process-buffer -process)))) ;; When I an able to identify the ;; connection to the server AND I've - ;; received NO reponse for + ;; received NO response for ;; nntp-connection-timeout seconds. (when (and -buffer (eq 0 (buffer-size -buffer))) ;; Close the connection. Take no @@ -694,7 +660,7 @@ command whose response triggered the error." (when -timer (nnheader-cancel-timer -timer))) nil)) - (setf (symbol-function 'nntp-report) nntp-report-n)) + (setq nntp--report-1 nntp-report-n)) nntp-with-open-group-internal)) (defmacro nntp-with-open-group (group server &optional connectionless &rest forms) @@ -780,21 +746,32 @@ command whose response triggered the error." (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))))) + (let ((buffer (nntp-find-connection-buffer nntp-server-buffer))) + (unless infos + (with-current-buffer buffer + (setq nntp-retrieval-in-progress nil))) + (when (and buffer + infos + (with-current-buffer buffer + (not nntp-retrieval-in-progress))) + ;; 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 buffer + (erase-buffer) + ;; Mark this buffer as "in use" in case we try to issue two + ;; retrievals from the same server. This shouldn't happen, + ;; so this is mostly a sanity check. + (setq nntp-retrieval-in-progress t) + (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 @@ -804,6 +781,8 @@ command whose response triggered the error." (car infos))) (received 0) (last-point 1)) + (with-current-buffer buf + (setq nntp-retrieval-in-progress nil)) (when (and buf count) (with-current-buffer buf @@ -826,7 +805,8 @@ command whose response triggered the error." (progn (nntp-copy-to-buffer nntp-server-buffer (point-min) (point-max)) - (gnus-groups-to-gnus-format method gnus-active-hashtb t)) + (with-current-buffer nntp-server-buffer + (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)) @@ -847,7 +827,14 @@ command whose response triggered the error." "Retrieve group info on GROUPS." (nntp-with-open-group nil server - (when (nntp-find-connection-buffer nntp-server-buffer) + (when (and (nntp-find-connection-buffer nntp-server-buffer) + (with-current-buffer + (nntp-find-connection-buffer nntp-server-buffer) + (if (not nntp-retrieval-in-progress) + t + (message "Warning: Refusing to do retrieval from %s because a retrieval is already happening" + server) + nil))) (catch 'done (save-excursion ;; Erase nntp-server-buffer before nntp-inhibit-erase. @@ -996,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) @@ -1177,43 +1164,6 @@ command whose response triggered the error." (deffoo nntp-asynchronous-p () t) -(deffoo nntp-request-set-mark (group actions &optional server) - (when (and (not nntp-marks-is-evil) - nntp-marks-file-name) - (nntp-possibly-create-directory group server) - (nntp-open-marks group server) - (setq nntp-marks (nnheader-update-marks-actions nntp-marks actions)) - (nntp-save-marks group server)) - nil) - -(deffoo nntp-request-marks (group info &optional server) - (when (and (not nntp-marks-is-evil) - nntp-marks-file-name) - (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) - - ;;; Hooky functions. @@ -1240,17 +1190,21 @@ 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 - (nth 0 (auth-source-search :max 1 - ;; TODO: allow the virtual server name too - :host nntp-address - :port '("119" "nntp")))) + (nth 0 (auth-source-search + :max 1 + :host (list nntp-address (nnoo-current-server 'nntp)) + :port `("119" "nntp" ,(format "%s" nntp-port-number) + "563" "nntps" "snews")))) (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 @@ -1276,30 +1230,6 @@ If SEND-IF-FORCE, only send authinfo to the server if the (read-passwd (format "NNTP (%s@%s) password: " user nntp-address)))))))))) -(defun nntp-send-nosy-authinfo () - "Send the AUTHINFO to the nntp server." - (let ((user (read-string (format "NNTP (%s) user name: " nntp-address)))) - (unless (member user '(nil "")) - (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" user) - (when t ;???Should check if AUTHINFO succeeded - (nntp-send-command "^2.*\r?\n" "AUTHINFO PASS" - (read-passwd (format "NNTP (%s@%s) password: " - user nntp-address))))))) - -(defun nntp-send-authinfo-from-file () - "Send the AUTHINFO to the nntp server. - -The authinfo login name is taken from the user's login name and the -password contained in '~/.nntp-authinfo'." - (when (file-exists-p "~/.nntp-authinfo") - (with-temp-buffer - (insert-file-contents "~/.nntp-authinfo") - (goto-char (point-min)) - (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" (user-login-name)) - (nntp-send-command - "^2.*\r?\n" "AUTHINFO PASS" - (buffer-substring (point) (point-at-eol)))))) - ;;; Internal functions. (defun nntp-handle-authinfo (process) @@ -1325,6 +1255,7 @@ password contained in '~/.nntp-authinfo'." (set (make-local-variable 'nntp-process-to-buffer) nil) (set (make-local-variable 'nntp-process-start-point) nil) (set (make-local-variable 'nntp-process-decode) nil) + (set (make-local-variable 'nntp-retrieval-in-progress) nil) (current-buffer))) (defun nntp-open-connection (buffer) @@ -1339,8 +1270,8 @@ password contained in '~/.nntp-authinfo'." (nntp-kill-buffer ,pbuffer))))) (process (condition-case err - (let ((coding-system-for-read nntp-coding-system-for-read) - (coding-system-for-write nntp-coding-system-for-write) + (let ((coding-system-for-read 'binary) + (coding-system-for-write 'binary) (map '((nntp-open-network-stream network) (network-only plain) ; compat (nntp-open-plain-stream plain) @@ -1351,7 +1282,7 @@ password contained in '~/.nntp-authinfo'." "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" + :capability-command "HELP\r\n" :success "^3" :starttls-function (lambda (capabilities) @@ -1370,11 +1301,21 @@ password contained in '~/.nntp-authinfo'." (nnheader-cancel-timer timer)) (when (and process (not (memq (process-status process) '(open run)))) + (with-current-buffer pbuffer + (goto-char (point-min)) + (nnheader-report 'nntp "Error when connecting: %s" + (buffer-substring (point) (line-end-position)))) (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))) @@ -1415,14 +1356,6 @@ password contained in '~/.nntp-authinfo'." nntp-process-start-point (point-max)) (setq after-change-functions '(nntp-after-change-function)))) -(defun nntp-async-timer-handler () - (mapcar - (lambda (proc) - (if (memq (process-status proc) '(open run)) - (nntp-async-trigger proc) - (nntp-async-stop proc))) - nntp-async-process-list)) - (defun nntp-async-stop (proc) (setq nntp-async-process-list (delq proc nntp-async-process-list)) (when (and nntp-async-timer (not nntp-async-process-list)) @@ -1472,7 +1405,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. @@ -1682,7 +1615,7 @@ password contained in '~/.nntp-authinfo'." ;; for the first available article. Obviously, a client can ;; use that entry to avoid making unnecessary requests. The ;; only problem is for a client that assumes that the response - ;; will always be within the requested ranage. For such a + ;; will always be within the requested range. For such a ;; client, we can get N copies of the same entry (one for each ;; XOVER command sent to the server). @@ -1700,7 +1633,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)) @@ -2139,95 +2072,6 @@ Please refer to the following variables to customize the connection: (delete-region (point) (point-max))) proc))) -;; Marks handling - -(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 (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)))) - -(autoload 'time-less-p "time-date") - -(defun nntp-marks-changed-p (group 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 - (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 (nntp-group-pathname server group nntp-marks-file-name))) - (condition-case err - (progn - (nntp-possibly-create-directory group server) - (with-temp-file file - (erase-buffer) - (gnus-prin1 nntp-marks) - (insert "\n")) - (gnus-sethash file - (nth 5 (file-attributes file)) - nntp-marks-modtime)) - (error (or (gnus-yes-or-no-p - (format "Could not write to %s (%s). Continue? " file err)) - (error "Cannot write to %s (%s)" file err)))))) - -(defun nntp-open-marks (group 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 - (gnus-sethash file (nth 5 (file-attributes file)) - nntp-marks-modtime) - (nnheader-insert-file-contents file) - (setq nntp-marks (read (current-buffer))) - (dolist (el gnus-article-unpropagated-mark-lists) - (setq nntp-marks (gnus-remassoc el nntp-marks)))) - (error (or (gnus-yes-or-no-p - (format "Error reading nntp marks file %s (%s). Continuing will use marks from .newsrc.eld. Continue? " file err)) - (error "Cannot read nntp marks file %s (%s)" file err)))) - ;; User didn't have a .marks file. Probably first time - ;; user of the .marks stuff. Bootstrap it from .newsrc.eld. - (let ((info (gnus-get-info - (gnus-group-prefixed-name - 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" - decoded-name))))) - (provide 'nntp) ;;; nntp.el ends here