X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=lisp%2Fnntp.el;h=5380fd17080a3436b2c24043f822e198123dc59b;hb=refs%2Ftags%2Ft-gnus-6_15_3-06-last-;hp=5ced1d77d82464a1d88000075a5254fa463cbd7b;hpb=a2d6af2c24264119c5aff0ef0063733674eef102;p=elisp%2Fgnus.git- diff --git a/lisp/nntp.el b/lisp/nntp.el index 5ced1d7..5380fd1 100644 --- a/lisp/nntp.el +++ b/lisp/nntp.el @@ -1,9 +1,10 @@ ;;; nntp.el --- nntp access for Gnus ;; Copyright (C) 1987, 1988, 1989, 1990, 1992, 1993, 1994, 1995, 1996, -;; 1997, 1998, 2000 +;; 1997, 1998, 2000, 2001 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen +;; Katsumi Yamaoka ;; Keywords: news ;; This file is part of GNU Emacs. @@ -26,20 +27,55 @@ ;;; Code: +(eval-when-compile (require 'cl)) +(eval-when-compile (require 'gnus-clfns)) + (require 'nnheader) (require 'nnoo) (require 'gnus-util) (nnoo-declare nntp) -(eval-when-compile (require 'cl)) - (defvoo nntp-address nil "Address of the physical nntp server.") (defvoo nntp-port-number "nntp" "Port number on the physical nntp server.") +(defvoo nntp-list-options nil + "List of newsgroup name used for a option of the LIST command to +restrict the listing output to only the specified newsgroups. +Each newsgroup name can be a shell-style wildcard, for instance, +\"fj.*\", \"japan.*\", etc. Fortunately, if the server can accept +such a option, it will probably make gnus run faster. You may +use it as a server variable as follows: + +\(setq gnus-select-method + '(nntp \"news.somewhere.edu\" + (nntp-list-options (\"fj.*\" \"japan.*\"))))") + +(defvoo nntp-options-subscribe nil + "Regexp matching the newsgroup names which will be subscribed +unconditionally. It may be effective as well as `nntp-list-options' +even though the server could not accept a shell-style wildcard as a +option of the LIST command. You may use it as a server variable as +follows: + +\(setq gnus-select-method + '(nntp \"news.somewhere.edu\" + (nntp-options-subscribe \"^fj\\\\.\\\\|^japan\\\\.\")))") + +(defvoo nntp-options-not-subscribe nil + "Regexp matching the newsgroup names which will not be subscribed +unconditionally. It may be effective as well as `nntp-list-options' +even though the server could not accept a shell-style wildcard as a +option of the LIST command. You may use it as a server variable as +follows: + +\(setq gnus-select-method + '(nntp \"news.somewhere.edu\" + (nntp-options-not-subscribe \"\\\\.binaries\\\\.\")))") + (defvoo nntp-server-opened-hook '(nntp-send-mode-reader) "*Hook used for sending commands to the server at startup. The default value is `nntp-send-mode-reader', which makes an innd @@ -153,12 +189,6 @@ server there that you can connect to. See also (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.") - -(defvoo nntp-coding-system-for-write 'binary - "*Coding system to write to NNTP.") - (defcustom nntp-authinfo-file "~/.authinfo" ".netrc-like file that holds nntp authinfo passwords." :type @@ -180,7 +210,12 @@ server there that you can connect to. See also (defvoo nntp-connection-timeout nil "*Number of seconds to wait before an nntp connection times out. -If this variable is nil, which is the default, no timers are set.") +If this variable is nil, which is the default, no timers are set. +NOTE: This variable is never seen to work in Emacs 20 and XEmacs 21.") + +(defvoo nntp-prepare-post-hook nil + "*Hook run just before posting an article. It is supposed to be used for +inserting Cancel-Lock headers, signing with Gpg, etc.") ;;; Internal variables. @@ -273,13 +308,18 @@ noticing asynchronous data.") (nnheader-report 'nntp "Server closed connection")) (t (goto-char (point-max)) - (let ((limit (point-min))) + (let ((limit (point-min)) + response) (while (not (re-search-backward wait-for limit t)) (nntp-accept-process-output process) ;; We assume that whatever we wait for is less than 1000 ;; characters long. (setq limit (max (- (point-max) 1000) (point-min))) - (goto-char (point-max)))) + (goto-char (point-max))) + (setq response (match-string 0)) + (save-current-buffer + (set-buffer nntp-server-buffer) + (setq nntp-process-response response))) (nntp-decode-text (not decode)) (unless discard (save-excursion @@ -289,8 +329,8 @@ noticing asynchronous data.") ;; Nix out "nntp reading...." message. (when nntp-have-messaged (setq nntp-have-messaged nil) - (nnheader-message 5 "")) - t)))) + (nnheader-message 5 "")))) + t)) (unless discard (erase-buffer))))) @@ -304,7 +344,7 @@ noticing asynchronous data.") (let ((alist nntp-connection-alist) (buffer (if (stringp buffer) (get-buffer buffer) buffer)) process entry) - (while (setq entry (pop alist)) + (while (and alist (setq entry (pop alist))) (when (eq buffer (cadr entry)) (setq process (car entry) alist nil))) @@ -349,10 +389,13 @@ noticing asynchronous data.") (wait-for (nntp-wait-for process wait-for buffer decode)) (t t))) - (error - (nnheader-report 'nntp "Couldn't open connection to %s: %s" + (error + (nnheader-report 'nntp "Couldn't open connection to %s: %s" address err)) - (quit nil))))) + (quit + (message "Quit retrieving data from nntp") + (signal 'quit nil) + nil))))) (defsubst nntp-send-command (wait-for &rest strings) "Send STRINGS to server and wait until WAIT-FOR returns." @@ -489,75 +532,85 @@ noticing asynchronous data.") "Retrieve group info on GROUPS." (nntp-possibly-change-group nil server) (when (nntp-find-connection-buffer nntp-server-buffer) - (save-excursion - ;; Erase nntp-server-buffer before nntp-inhibit-erase. - (set-buffer nntp-server-buffer) - (erase-buffer) - (set-buffer (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 (car groups))) - (erase-buffer) - (let ((count 0) - (received 0) - (last-point (point-min)) - (nntp-inhibit-erase t) - (buf (nntp-find-connection-buffer nntp-server-buffer)) - (command (if nntp-server-list-active-group "LIST ACTIVE" "GROUP"))) - (while groups - ;; Send the command to the server. - (nntp-send-command nil command (pop groups)) - (incf count) - ;; Every 400 requests we have to read the stream in - ;; order to avoid deadlocks. - (when (or (null groups) ;All requests have been sent. - (zerop (% count nntp-maximum-request))) - (nntp-accept-response) - (while (progn - ;; Search `blue moon' in this file for the - ;; reason why set-buffer here. - (set-buffer buf) - (goto-char last-point) - ;; Count replies. - (while (re-search-forward "^[0-9]" nil t) - (incf received)) - (setq last-point (point)) - (< received count)) - (nntp-accept-response)))) - - ;; Wait for the reply from the final command. - (set-buffer buf) - (goto-char (point-max)) - (re-search-backward "^[0-9]" nil t) - (when (looking-at "^[23]") - (while (progn - (set-buffer buf) - (goto-char (point-max)) - (if (not nntp-server-list-active-group) - (not (re-search-backward "\r?\n" (- (point) 3) t)) - (not (re-search-backward "^\\.\r?\n" (- (point) 4) t)))) - (nntp-accept-response))) - - ;; Now all replies are received. We remove CRs. - (set-buffer buf) - (goto-char (point-min)) - (while (search-forward "\r" nil t) - (replace-match "" t t)) - - (if (not nntp-server-list-active-group) - (progn - (copy-to-buffer nntp-server-buffer (point-min) (point-max)) - 'group) - ;; We have read active entries, so we just delete the - ;; superfluous gunk. + (catch 'done + (save-excursion + ;; Erase nntp-server-buffer before nntp-inhibit-erase. + (set-buffer nntp-server-buffer) + (erase-buffer) + (set-buffer (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 (car groups))) + (erase-buffer) + (let ((count 0) + (received 0) + (last-point (point-min)) + (nntp-inhibit-erase t) + (buf (nntp-find-connection-buffer nntp-server-buffer)) + (command (if nntp-server-list-active-group "LIST ACTIVE" "GROUP"))) + (while groups + ;; Send the command to the server. + (nntp-send-command nil command (pop groups)) + (incf count) + ;; Every 400 requests we have to read the stream in + ;; order to avoid deadlocks. + (when (or (null groups) ;All requests have been sent. + (zerop (% count nntp-maximum-request))) + (nntp-accept-response) + (while (and (gnus-buffer-live-p buf) + (progn + ;; Search `blue moon' in this file for the + ;; reason why set-buffer here. + (set-buffer buf) + (goto-char last-point) + ;; Count replies. + (while (re-search-forward "^[0-9]" nil t) + (incf received)) + (setq last-point (point)) + (< received count))) + (nntp-accept-response)))) + + ;; Wait for the reply from the final command. + (unless (gnus-buffer-live-p buf) + (nnheader-report 'nntp "Connection to %s is closed." server) + (throw 'done nil)) + (set-buffer buf) + (goto-char (point-max)) + (re-search-backward "^[0-9]" nil t) + (when (looking-at "^[23]") + (while (and (gnus-buffer-live-p buf) + (progn + (set-buffer buf) + (goto-char (point-max)) + (if (not nntp-server-list-active-group) + (not (re-search-backward "\r?\n" (- (point) 3) t)) + (not (re-search-backward "^\\.\r?\n" + (- (point) 4) t))))) + (nntp-accept-response))) + + ;; Now all replies are received. We remove CRs. + (unless (gnus-buffer-live-p buf) + (nnheader-report 'nntp "Connection to %s is closed." server) + (throw 'done nil)) + (set-buffer buf) (goto-char (point-min)) - (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)) - 'active))))) - + (while (search-forward "\r" nil t) + (replace-match "" t t)) + + (if (not nntp-server-list-active-group) + (progn + (copy-to-buffer nntp-server-buffer (point-min) (point-max)) + 'group) + ;; 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)))) + (copy-to-buffer nntp-server-buffer (point-min) (point-max)) + 'active)))))) + (deffoo nntp-retrieve-articles (articles &optional group server) (nntp-possibly-change-group group server) (save-excursion @@ -737,8 +790,40 @@ noticing asynchronous data.") (nntp-kill-buffer (process-buffer process))))) (deffoo nntp-request-list (&optional server) + "List active groups. If `nntp-list-options' is non-nil, the listing +output from the server will be restricted to the specified newsgroups. +If `nntp-options-subscribe' is non-nil, remove newsgroups that do not +match the regexp. If `nntp-options-not-subscribe' is non-nil, remove +newsgroups that match the regexp." (nntp-possibly-change-group nil server) - (nntp-send-command-and-decode "\r?\n\\.\r?\n" "LIST")) + (with-current-buffer nntp-server-buffer + (prog1 + (if (not nntp-list-options) + (nntp-send-command-and-decode "\r?\n\\.\r?\n" "LIST") + (let ((options (if (consp nntp-list-options) + nntp-list-options + (list nntp-list-options))) + (ret t)) + (erase-buffer) + (while options + (goto-char (point-max)) + (narrow-to-region (point) (point)) + (setq ret (and ret + (nntp-send-command-nodelete + "\r?\n\\.\r?\n" + (format "LIST ACTIVE %s" (car options)))) + options (cdr options)) + (nntp-decode-text)) + (widen) + ret)) + (when (and (stringp nntp-options-subscribe) + (not (string-equal "" nntp-options-subscribe))) + (goto-char (point-min)) + (keep-lines nntp-options-subscribe)) + (when (and (stringp nntp-options-not-subscribe) + (not (string-equal "" nntp-options-not-subscribe))) + (goto-char (point-min)) + (flush-lines nntp-options-subscribe))))) (deffoo nntp-request-list-newsgroups (&optional server) (nntp-possibly-change-group nil server) @@ -748,16 +833,44 @@ noticing asynchronous data.") (nntp-possibly-change-group nil server) (save-excursion (set-buffer nntp-server-buffer) - (prog1 - (nntp-send-command - "^\\.\r?\n" "NEWGROUPS" - (format-time-string "%y%m%d %H%M%S" (date-to-time date))) - (nntp-decode-text)))) + (let* ((time (date-to-time date)) + (ls (- (cadr time) (nth 8 (decode-time time))))) + (cond ((< ls 0) + (setcar time (1- (car time))) + (setcar (cdr time) (+ ls 65536))) + ((>= ls 65536) + (setcar time (1+ (car time))) + (setcar (cdr time) (- ls 65536))) + (t + (setcar (cdr time) ls))) + (prog1 + (nntp-send-command + "^\\.\r?\n" "NEWGROUPS" + (format-time-string "%y%m%d %H%M%S" time) + "GMT") + (nntp-decode-text))))) (deffoo nntp-request-post (&optional server) (nntp-possibly-change-group nil server) (when (nntp-send-command "^[23].*\r?\n" "POST") - (nntp-send-buffer "^[23].*\n"))) + (let ((response (save-current-buffer + (set-buffer nntp-server-buffer) + nntp-process-response)) + server-id) + (when (and response + (string-match "^[23].*\\(<[^\t\n @<>]+@[^\t\n @<>]+>\\)" + response)) + (setq server-id (match-string 1 response)) + (narrow-to-region (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (1- (point)) + (point-max))) + (unless (mail-fetch-field "Message-ID") + (goto-char (point-min)) + (insert "Message-ID: " server-id "\n")) + (widen)) + (run-hooks 'nntp-prepare-post-hook) + (nntp-send-buffer "^[23].*\n")))) (deffoo nntp-request-type (group article) 'news) @@ -800,8 +913,9 @@ If SEND-IF-FORCE, only send authinfo to the server if the (or passwd nntp-authinfo-password (setq nntp-authinfo-password - (mail-source-read-passwd (format "NNTP (%s@%s) password: " - user nntp-address)))))))))) + (mail-source-read-passwd + (format "NNTP (%s@%s) password: " + user nntp-address)))))))))) (defun nntp-send-nosy-authinfo () "Send the AUTHINFO to the nntp server." @@ -848,7 +962,6 @@ password contained in '~/.nntp-authinfo'." (format " *server %s %s %s*" nntp-address nntp-port-number (gnus-buffer-exists-p buffer)))) - (mm-enable-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) @@ -869,18 +982,22 @@ password contained in '~/.nntp-authinfo'." (nntp-kill-buffer ,pbuffer))))) (process (condition-case () - (let ((coding-system-for-read nntp-coding-system-for-read) - (coding-system-for-write nntp-coding-system-for-write)) - (funcall nntp-open-connection-function pbuffer)) + (funcall nntp-open-connection-function pbuffer) (error nil) - (quit nil)))) + (quit + (message "Quit opening connection") + (nntp-kill-buffer pbuffer) + (signal 'quit nil) + nil)))) (when timer (nnheader-cancel-timer timer)) + (unless process + (nntp-kill-buffer pbuffer)) (when (and (buffer-name pbuffer) process) (process-kill-without-query process) - (nntp-wait-for process "^.*\n" buffer nil t) - (if (memq (process-status process) '(open run)) + (if (and (nntp-wait-for process "^2.*\n" buffer nil t) + (memq (process-status process) '(open run))) (prog1 (caar (push (list process buffer nil) nntp-connection-alist)) (push process nntp-connection-list) @@ -896,7 +1013,8 @@ password contained in '~/.nntp-authinfo'." nil)))) (defun nntp-open-network-stream (buffer) - (open-network-stream "nntpd" buffer nntp-address nntp-port-number)) + (open-network-stream-as-binary + "nntpd" buffer nntp-address nntp-port-number)) (defun nntp-open-ssl-stream (buffer) (let* ((ssl-program-arguments '("-connect" (concat host ":" service))) @@ -982,7 +1100,7 @@ password contained in '~/.nntp-authinfo'." (if (memq (following-char) '(?4 ?5)) ;; wants credentials? (if (looking-at "480") - (nntp-handle-authinfo nntp-process-to-buffer) + (nntp-handle-authinfo process) ;; report error message. (nntp-snarf-error-message) (nntp-do-callback nil)) @@ -991,6 +1109,10 @@ password contained in '~/.nntp-authinfo'." (goto-char (point-max)) (when (re-search-backward nntp-process-wait-for nntp-process-start-point t) + (let ((response (match-string 0))) + (save-current-buffer + (set-buffer nntp-server-buffer) + (setq nntp-process-response response))) (nntp-async-stop process) ;; convert it. (when (gnus-buffer-exists-p nntp-process-to-buffer) @@ -1073,7 +1195,9 @@ password contained in '~/.nntp-authinfo'." (delete-char 2)) ;; Delete status line. (goto-char (point-min)) - (delete-region (point) (progn (forward-line 1) (point))) + (while (looking-at "[1-5][0-9][0-9] .*\n") + ;; For some unknown reason, there is more than one status line. + (delete-region (point) (progn (forward-line 1) (point)))) ;; Remove "." -> ".." encoding. (while (search-forward "\n.." nil t) (delete-char -1)))) @@ -1151,7 +1275,7 @@ password contained in '~/.nntp-authinfo'." (while (and (cdr articles) (< (- (nth 1 articles) (car articles)) nntp-nov-gap)) (setq articles (cdr articles))) - + (setq in-process-buffer-p (stringp nntp-server-xover)) (nntp-send-xover-command first (car articles)) (setq articles (cdr articles)) @@ -1159,7 +1283,7 @@ password contained in '~/.nntp-authinfo'." (when (and nntp-server-xover in-process-buffer-p) ;; Don't count tried request. (setq count (1+ count)) - + ;; Every 400 requests we have to read the stream in ;; order to avoid deadlocks. (when (or (null articles) ;All requests have been sent. @@ -1267,11 +1391,13 @@ password contained in '~/.nntp-authinfo'." (save-excursion (set-buffer buffer) (erase-buffer) - (let ((proc (apply - 'start-process - "nntpd" buffer nntp-telnet-command nntp-telnet-switches)) + (let ((proc (as-binary-process + (apply + 'start-process + "nntpd" buffer nntp-telnet-command nntp-telnet-switches))) (case-fold-search t)) (when (memq (process-status proc) '(open run)) + (nntp-wait-for-string "^r?telnet") (process-send-string proc "set escape \^X\n") (cond ((and nntp-open-telnet-envuser nntp-telnet-user-name) @@ -1301,7 +1427,7 @@ password contained in '~/.nntp-authinfo'." (beginning-of-line) (delete-region (point-min) (point)) (process-send-string proc "\^]") - (nntp-wait-for-string "^telnet") + (nntp-wait-for-string "^r?telnet") (process-send-string proc "mode character\n") (accept-process-output proc 1) (sit-for 1) @@ -1313,13 +1439,15 @@ password contained in '~/.nntp-authinfo'." (defun nntp-open-rlogin (buffer) "Open a connection to SERVER using rsh." (let ((proc (if nntp-rlogin-user-name - (apply 'start-process - "nntpd" buffer nntp-rlogin-program - nntp-address "-l" nntp-rlogin-user-name - nntp-rlogin-parameters) - (apply 'start-process - "nntpd" buffer nntp-rlogin-program nntp-address - nntp-rlogin-parameters)))) + (as-binary-process + (apply 'start-process + "nntpd" buffer nntp-rlogin-program + nntp-address "-l" nntp-rlogin-user-name + nntp-rlogin-parameters)) + (as-binary-process + (apply 'start-process + "nntpd" buffer nntp-rlogin-program nntp-address + nntp-rlogin-parameters))))) (save-excursion (set-buffer buffer) (nntp-wait-for-string "^\r*20[01]")