;;; 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 <larsi@gnus.org>
+;; Katsumi Yamaoka <yamaoka@jpl.org>
;; Keywords: news
;; This file is part of GNU Emacs.
;;; 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
(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
(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.
(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
;; 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)))))
(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)))
(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."
"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
(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)
(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)
(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."
(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)
(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)
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)))
(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))
(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)
(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))))
(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))
(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.
(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)
(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)
(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]")
projects / elisp / gnus.git- / blobdiff