diff options
Diffstat (limited to 'lisp/gnus/nntp.el')
| -rw-r--r-- | lisp/gnus/nntp.el | 328 |
1 files changed, 259 insertions, 69 deletions
diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index 2623df58e4d..c8c14da4df7 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -31,6 +31,8 @@ (require 'nnheader) (require 'nnoo) (require 'gnus-util) +(require 'gnus) +(require 'gnus-group) ;; gnus-group-name-charset (nnoo-declare nntp) @@ -86,6 +88,7 @@ Direct connections: Indirect connections: - `nntp-open-via-rlogin-and-telnet', +- `nntp-open-via-rlogin-and-netcat', - `nntp-open-via-telnet-and-telnet'.") (defvoo nntp-never-echoes-commands nil @@ -109,20 +112,22 @@ This is where you would put \"runsocks\" or stuff like that.") (defvoo nntp-telnet-command "telnet" "*Telnet command used to connect to the nntp server. -This command is used by the various nntp-open-via-* methods.") +This command is used by the methods `nntp-open-telnet-stream', +`nntp-open-via-rlogin-and-telnet' and `nntp-open-via-telnet-and-telnet'.") (defvoo nntp-telnet-switches '("-8") "*Switches given to the telnet command `nntp-telnet-command'.") (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 an indirect connection method (nntp-open-via-*).") +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. -This command is used by the `nntp-open-via-rlogin-and-telnet' method. -The default is \"rsh\", but \"ssh\" is a popular alternative.") +This command is used by the methods `nntp-open-via-rlogin-and-telnet' +and `nntp-open-via-rlogin-and-netcat'. The default is \"rsh\", but \"ssh\" +is a popular alternative.") (defvoo nntp-via-rlogin-command-switches nil "*Switches given to the rlogin command `nntp-via-rlogin-command'. @@ -138,9 +143,16 @@ This command is used by the `nntp-open-via-telnet-and-telnet' method.") (defvoo nntp-via-telnet-switches '("-8") "*Switches given to the telnet command `nntp-via-telnet-command'.") +(defvoo nntp-via-netcat-command "nc" + "*Netcat command used to connect to the nntp server. +This command is used by the `nntp-open-via-rlogin-and-netcat' method.") + +(defvoo nntp-via-netcat-switches nil + "*Switches given to the netcat command `nntp-via-netcat-command'.") + (defvoo nntp-via-user-name nil "*User name to log in on an intermediate host with. -This variable is used by the `nntp-open-via-telnet-and-telnet' method.") +This variable is used by the various nntp-open-via-* methods.") (defvoo nntp-via-user-password nil "*Password to use to log in on an intermediate host with. @@ -148,8 +160,7 @@ This variable is used by the `nntp-open-via-telnet-and-telnet' method.") (defvoo nntp-via-address nil "*Address of an intermediate host to connect to. -This variable is used by the `nntp-open-via-rlogin-and-telnet' and -`nntp-open-via-telnet-and-telnet' methods.") +This variable is used by the various nntp-open-via-* methods.") (defvoo nntp-via-envuser nil "*Whether both telnet client and server support the ENVIRON option. @@ -206,6 +217,21 @@ server there that you can connect to. See also (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 @@ -252,6 +278,7 @@ to insert Cancel-Lock headers.") (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) @@ -339,14 +366,16 @@ be restored and the command retried." (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 "48[02]")) (memq (process-status process) '(open run))) (cond ((looking-at "480") - (nntp-handle-authinfo process)) + (nntp-handle-authinfo process)) ((looking-at "482") (nnheader-report 'nntp (get 'nntp-authinfo-rejected 'error-message)) (signal 'nntp-authinfo-rejected nil)) @@ -394,6 +423,11 @@ be restored and the command retried." (kill-buffer buffer) (nnheader-init-server-buffer))) +(defun nntp-erase-buffer (buffer) + "Erase contents of BUFFER." + (with-current-buffer buffer + (erase-buffer))) + (defsubst nntp-find-connection (buffer) "Find the connection delivering to BUFFER." (let ((alist nntp-connection-alist) @@ -428,9 +462,7 @@ be restored and the command retried." (if process (progn (unless (or nntp-inhibit-erase nnheader-callback-function) - (save-excursion - (set-buffer (process-buffer process)) - (erase-buffer))) + (nntp-erase-buffer (process-buffer process))) (condition-case err (progn (when command @@ -459,9 +491,7 @@ be restored and the command retried." "Send STRINGS to server and wait until WAIT-FOR returns." (when (and (not nnheader-callback-function) (not nntp-inhibit-output)) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer))) + (nntp-erase-buffer nntp-server-buffer)) (let* ((command (mapconcat 'identity strings " ")) (process (nntp-find-connection nntp-server-buffer)) (buffer (and process (process-buffer process))) @@ -488,8 +518,7 @@ be restored and the command retried." (goto-char pos) (if (looking-at (regexp-quote command)) (delete-region pos (progn (forward-line 1) - (gnus-point-at-bol)))) - ))) + (point-at-bol))))))) (nnheader-report 'nntp "Couldn't open connection to %s." nntp-address)))) @@ -513,7 +542,7 @@ be restored and the command retried." (goto-char pos) (if (looking-at (regexp-quote command)) (delete-region pos (progn (forward-line 1) - (gnus-point-at-bol))))))) + (point-at-bol))))))) (nnheader-report 'nntp "Couldn't open connection to %s." nntp-address)))) @@ -521,9 +550,7 @@ be restored and the command retried." "Send STRINGS to server and wait until WAIT-FOR returns." (when (and (not nnheader-callback-function) (not nntp-inhibit-output)) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer))) + (nntp-erase-buffer nntp-server-buffer)) (let* ((command (mapconcat 'identity strings " ")) (process (nntp-find-connection nntp-server-buffer)) (buffer (and process (process-buffer process))) @@ -538,11 +565,11 @@ be restored and the command retried." (unless wait-for (nntp-accept-response) (save-excursion - (set-buffer buffer) - (goto-char pos) - (if (looking-at (regexp-quote command)) - (delete-region pos (progn (forward-line 1) (gnus-point-at-bol)))) - ))) + (set-buffer buffer) + (goto-char pos) + (if (looking-at (regexp-quote command)) + (delete-region pos (progn (forward-line 1) (point-at-bol)))) + ))) (nnheader-report 'nntp "Couldn't open connection to %s." nntp-address)))) @@ -551,9 +578,8 @@ be restored and the command retried." "Send the current buffer to server and wait until WAIT-FOR returns." (when (and (not nnheader-callback-function) (not nntp-inhibit-output)) - (save-excursion - (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) - (erase-buffer))) + (nntp-erase-buffer + (nntp-find-connection-buffer nntp-server-buffer))) (nntp-encode-text) (mm-with-unibyte-current-buffer ;; Some encoded unicode text contains character 0x80-0x9f e.g. Euro. @@ -575,7 +601,12 @@ be restored and the command retried." ;; 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. @@ -615,7 +646,7 @@ command whose response triggered the error." (let ((timer (and nntp-connection-timeout - (nnheader-run-at-time + (run-at-time nntp-connection-timeout nil '(lambda () (let ((process (nntp-find-connection @@ -637,7 +668,8 @@ command whose response triggered the error." (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))) @@ -717,8 +749,7 @@ command whose response triggered the error." (catch 'done (save-excursion ;; Erase nntp-server-buffer before nntp-inhibit-erase. - (set-buffer nntp-server-buffer) - (erase-buffer) + (nntp-erase-buffer nntp-server-buffer) (set-buffer (nntp-find-connection-buffer nntp-server-buffer)) ;; The first time this is run, this variable is `try'. So we ;; try. @@ -1046,6 +1077,54 @@ command whose response triggered the error." (deffoo nntp-asynchronous-p () t) +(deffoo nntp-request-set-mark (group actions &optional server) + (unless nntp-marks-is-evil + (nntp-possibly-create-directory group server) + (nntp-open-marks group server) + (dolist (action actions) + (let ((range (nth 0 action)) + (what (nth 1 action)) + (marks (nth 2 action))) + (assert (or (eq what 'add) (eq what 'del)) nil + "Unknown request-set-mark action: %s" what) + (dolist (mark marks) + (setq nntp-marks (gnus-update-alist-soft + mark + (funcall (if (eq what 'add) 'gnus-range-add + 'gnus-remove-from-range) + (cdr (assoc mark nntp-marks)) range) + nntp-marks))))) + (nntp-save-marks group server)) + nil) + +(deffoo nntp-request-update-info (group info &optional server) + (unless nntp-marks-is-evil + (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. (defun nntp-send-mode-reader () @@ -1063,11 +1142,11 @@ and a password. If SEND-IF-FORCE, only send authinfo to the server if the .authinfo file has the FORCE token." - (let* ((list (gnus-parse-netrc nntp-authinfo-file)) - (alist (gnus-netrc-machine list nntp-address "nntp")) - (force (gnus-netrc-get alist "force")) - (user (or (gnus-netrc-get alist "login") nntp-authinfo-user)) - (passwd (gnus-netrc-get alist "password"))) + (let* ((list (netrc-parse nntp-authinfo-file)) + (alist (netrc-machine list nntp-address "nntp")) + (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) force) (unless user @@ -1106,7 +1185,7 @@ password contained in '~/.nntp-authinfo'." (nntp-send-command "^3.*\r?\n" "AUTHINFO USER" (user-login-name)) (nntp-send-command "^2.*\r?\n" "AUTHINFO PASS" - (buffer-substring (point) (gnus-point-at-eol)))))) + (buffer-substring (point) (point-at-eol)))))) ;;; Internal functions. @@ -1116,9 +1195,7 @@ password contained in '~/.nntp-authinfo'." (funcall nntp-authinfo-function) ;; We have to re-send the function that was interrupted by ;; the authinfo request. - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer)) + (nntp-erase-buffer nntp-server-buffer) (nntp-send-string process last))) (defun nntp-make-process-buffer (buffer) @@ -1144,7 +1221,7 @@ password contained in '~/.nntp-authinfo'." (let* ((pbuffer (nntp-make-process-buffer buffer)) (timer (and nntp-connection-timeout - (nnheader-run-at-time + (run-at-time nntp-connection-timeout nil `(lambda () (nntp-kill-buffer ,pbuffer))))) @@ -1155,7 +1232,7 @@ password contained in '~/.nntp-authinfo'." (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)))) @@ -1223,12 +1300,9 @@ password contained in '~/.nntp-authinfo'." "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)))) @@ -1254,7 +1328,7 @@ password contained in '~/.nntp-authinfo'." ;; doesn't trigger after-change-functions. (unless nntp-async-timer (setq nntp-async-timer - (nnheader-run-at-time 1 1 'nntp-async-timer-handler))) + (run-at-time 1 1 'nntp-async-timer-handler))) (add-to-list 'nntp-async-process-list process)) (defun nntp-async-timer-handler () @@ -1340,22 +1414,22 @@ password contained in '~/.nntp-authinfo'." (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." @@ -1382,9 +1456,7 @@ password contained in '~/.nntp-authinfo'." (nntp-send-command "^[245].*\n" "GROUP" group) (setcar (cddr entry) group) (erase-buffer) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer)))))))) + (nntp-erase-buffer nntp-server-buffer))))))) (defun nntp-decode-text (&optional cr-only) "Decode the text in the current buffer." @@ -1594,10 +1666,8 @@ password contained in '~/.nntp-authinfo'." (setq commands (cdr commands))) ;; If none of the commands worked, we disable XOVER. (when (eq nntp-server-xover 'try) - (save-excursion - (set-buffer nntp-server-buffer) - (erase-buffer) - (setq nntp-server-xover nil))) + (nntp-erase-buffer nntp-server-buffer) + (setq nntp-server-xover nil)) nntp-server-xover)))) (defun nntp-find-group-and-number (&optional group) @@ -1847,6 +1917,36 @@ Please refer to the following variables to customize the connection: (delete-region (point) (point-max))) proc)) +(defun nntp-open-via-rlogin-and-netcat (buffer) + "Open a connection to an nntp server through an intermediate host. +First rlogin to the remote host, and then connect to the real news +server from there using the netcat command. + +Please refer to the following variables to customize the connection: +- `nntp-pre-command', +- `nntp-via-rlogin-command', +- `nntp-via-rlogin-command-switches', +- `nntp-via-user-name', +- `nntp-via-address', +- `nntp-via-netcat-command', +- `nntp-via-netcat-switches', +- `nntp-address', +- `nntp-port-number', +- `nntp-end-of-line'." + (let ((command `(,@(when nntp-pre-command + (list nntp-pre-command)) + ,nntp-via-rlogin-command + ,@(when nntp-via-rlogin-command-switches + nntp-via-rlogin-command-switches) + ,@(when nntp-via-user-name + (list "-l" nntp-via-user-name)) + ,nntp-via-address + ,nntp-via-netcat-command + ,@nntp-via-netcat-switches + ,nntp-address + ,nntp-port-number))) + (apply 'start-process "nntpd" buffer command))) + (defun nntp-open-via-telnet-and-telnet (buffer) "Open a connection to an nntp server through an intermediate host. First telnet the remote host, and then telnet the real news server @@ -1922,6 +2022,96 @@ 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)))) + +(eval-and-compile + (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) ;;; arch-tag: 8655466a-b1b5-4929-9c45-7b1b2e767271 |