emacs: lisp/gnus/nntp.el comparison

comparison lisp/gnus/nntp.el @ 92778:054fe9aaf3e3

Use with-current-buffer. (nntp-send-buffer): Just set the buffer to unibyte rather than use the dubious mm-with-unibyte-current-buffer. (nntp-with-open-group-function): New function extracted from nntp-with-open-group macro. (nntp-with-open-group): Use the function, so it's easier to debug. Add indentation and debugging info. (nntp-open-telnet-stream, nntp-open-via-rlogin-and-telnet): Recommend the use of the netcat alternatives.

author	Stefan Monnier <monnier@iro.umontreal.ca>
date	Wed, 12 Mar 2008 19:56:09 +0000
parents	107ccd98fa12
children	a789a1138b08

comparison

equal deleted inserted replaced

-:1186239f19c8
+:054fe9aaf3e3
 (or (memq (process-status process) '(open run))
 (nntp-report "Server closed connection")))
 (defun nntp-record-command (string)
 "Record the command STRING."
-(save-excursion
+(with-current-buffer (get-buffer-create "*nntp-log*")
-(set-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"))))
 	 nil))))
 (defsubst nntp-wait-for (process wait-for buffer &optional decode discard)
 "Wait for WAIT-FOR to arrive from PROCESS."
-(save-excursion
+(with-current-buffer (process-buffer process)
-(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)))
 	    (setq response (match-string 0))
 	    (with-current-buffer nntp-server-buffer
 	      (setq nntp-process-response response)))
 	  (nntp-decode-text (not decode))
 	  (unless discard
-	    (save-excursion
+	    (with-current-buffer buffer
-	      (set-buffer buffer)
 	      (goto-char (point-max))
 	      (nntp-insert-buffer-substring (process-buffer process))
 	      ;; Nix out "nntp reading...." message.
 	      (when nntp-have-messaged
 		(setq nntp-have-messaged nil)
 		      nntp-never-echoes-commands
 		      (memq
 		       nntp-open-connection-function
 		       nntp-open-connection-functions-never-echo-commands))
 	    (nntp-accept-response)
-	    (save-excursion
+	    (with-current-buffer buffer
-	      (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-server-buffer
 				wait-for nnheader-callback-function)
 	  ;; If nothing to wait for, still remove possibly echo'ed commands
 	  (unless wait-for
 	    (nntp-accept-response)
-	    (save-excursion
+	    (with-current-buffer buffer
-	      (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-server-buffer
 				wait-for nnheader-callback-function t)
 	  ;; If nothing to wait for, still remove possibly echo'ed commands
 	  (unless wait-for
 	    (nntp-accept-response)
-	    (save-excursion
+	    (with-current-buffer buffer
-	      (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."
 (when (and (not nnheader-callback-function)
 	     (not nntp-inhibit-output))
 (nntp-erase-buffer
 (nntp-find-connection-buffer nntp-server-buffer)))
 (nntp-encode-text)
-(mm-with-unibyte-current-buffer
+;; Make sure we did not forget to encode some of the content.
-;; Some encoded unicode text contains character 0x80-0x9f e.g. Euro.
+(assert (save-excursion (goto-char (point-min))
-(process-send-region (nntp-find-connection nntp-server-buffer)
+(not (re-search-forward "[^\000-\377]" nil t))))
-			 (point-min) (point-max)))
+(mm-disable-multibyte)
+(process-send-region (nntp-find-connection nntp-server-buffer)
+(point-min) (point-max))
 (nntp-retrieve-data
 nil nntp-address nntp-port-number nntp-server-buffer
 wait-for nnheader-callback-function))
 (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
+simply ignore any further requests on a connection.  Closed
+connections are not detected until `accept-process-output' has updated
+the `process-status'.  Dropped connections are not detected until the
+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))
+(while (catch 'nntp-with-open-group-error
+;; Open the connection to the server
+;; NOTE: Existing connections are NOT tested.
+(nntp-possibly-change-group -group -server -connectionless)
+(let ((-timer
+(and nntp-connection-timeout
+(run-at-time
+nntp-connection-timeout nil
+(lambda ()
+(let* ((-process (nntp-find-connection
+nntp-server-buffer))
+(-buffer  (and -process
+(process-buffer -process))))
+;; When I an able to identify the
+;; connection to the server AND I've
+;; received NO reponse for
+;; nntp-connection-timeout seconds.
+(when (and -buffer (eq 0 (buffer-size -buffer)))
+;; Close the connection.  Take no
+;; other action as the accept input
+;; code will handle the closed
+;; connection.
+(nntp-kill-buffer -buffer))))))))
+(unwind-protect
+(setq nntp-with-open-group-internal
+(condition-case nil
+(funcall -bodyfun)
+(quit
+(unless debug-on-quit
+(nntp-close-server))
+(signal 'quit nil))))
+(when -timer
+(nnheader-cancel-timer -timer)))
+nil))
+(setf (symbol-function 'nntp-report) nntp-report-n))
+nntp-with-open-group-internal))
 (defmacro nntp-with-open-group (group server &optional connectionless &rest forms)
 "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
 simply ignore any further requests on a connection.  Closed
-connections are not detected until accept-process-output has updated
+connections are not detected until `accept-process-output' has updated
-the process-status.  Dropped connections are not detected until the
+the `process-status'.  Dropped connections are not detected until the
 connection timeouts (which may be several minutes) or
-nntp-connection-timeout has expired.  When these occur
+`nntp-connection-timeout' has expired.  When these occur
-nntp-with-open-group, opens a new connection then re-issues the NNTP
+`nntp-with-open-group', opens a new connection then re-issues the NNTP
 command whose response triggered the error."
+(declare (indent 2) (debug (form form [&optional symbolp] def-body)))
 (when (and (listp connectionless)
 	     (not (eq connectionless nil)))
 (setq forms (cons connectionless forms)
 	  connectionless nil))
-`(letf ((nntp-report-n (symbol-function 'nntp-report))
+`(nntp-with-open-group-function ,group ,server ,connectionless (lambda () ,@forms)))
-	  ((symbol-function 'nntp-report) (symbol-function 'nntp-report-1))
-	  (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.
-	      (nntp-possibly-change-group ,group ,server ,connectionless)
-	      (let ((timer
-		     (and nntp-connection-timeout
-			  (run-at-time
-			   nntp-connection-timeout nil
-			   '(lambda ()
-			      (let ((process (nntp-find-connection
-					      nntp-server-buffer))
-				    (buffer  (and process
-						  (process-buffer process))))
-				;; When I am able to identify the
-				;; connection to the server AND I've
-				;; received NO reponse for
-				;; nntp-connection-timeout seconds.
-				(when (and buffer (eq 0 (buffer-size buffer)))
-				  ;; Close the connection.  Take no
-				  ;; other action as the accept input
-				  ;; code will handle the closed
-				  ;; connection.
-				  (nntp-kill-buffer buffer))))))))
-		(unwind-protect
-		    (setq nntp-with-open-group-internal
-(condition-case nil
-			      (progn ,@forms)
-			    (quit
-			     (unless debug-on-quit
-			       (nntp-close-server))
-(signal 'quit nil))))
-		  (when timer
-		    (nnheader-cancel-timer timer)))
-		nil))
-(setf (symbol-function 'nntp-report) nntp-report-n))
-nntp-with-open-group-internal))
 (deffoo nntp-retrieve-headers (articles &optional group server fetch-old)
 "Retrieve the headers of ARTICLES."
 (nntp-with-open-group
 group server
-(save-excursion
+(with-current-buffer (nntp-find-connection-buffer nntp-server-buffer)
-(set-buffer (nntp-find-connection-buffer nntp-server-buffer))
 (erase-buffer)
 (if (and (not gnus-nov-is-evil)
 (not nntp-nov-is-evil)
 (nntp-retrieve-headers-with-xover articles fetch-old))
 ;; We successfully retrieved the headers via XOVER.
 (cons (car entry) point))
 map)))))
 (defun nntp-try-list-active (group)
 (nntp-list-active-group group)
-(save-excursion
+(with-current-buffer nntp-server-buffer
-(set-buffer nntp-server-buffer)
 (goto-char (point-min))
 (cond ((or (eobp)
 	       (looking-at "5[0-9]+"))
 	   (setq nntp-server-list-active-group nil))
 	  (t
 (when (nntp-send-command-and-decode
 "\r?\n\\.\r?\n" "ARTICLE"
 (if (numberp article) (int-to-string article) article))
 (if (and buffer
 (not (equal buffer nntp-server-buffer)))
-(save-excursion
+(with-current-buffer nntp-server-buffer
-(set-buffer nntp-server-buffer)
 (copy-to-buffer buffer (point-min) (point-max))
 (nntp-find-group-and-number group))
 (nntp-find-group-and-number group)))))
 (deffoo nntp-request-head (article &optional group server)
 (nntp-send-command "\r?\n\\.\r?\n" "LIST NEWSGROUPS")))
 (deffoo nntp-request-newgroups (date &optional server)
 (nntp-with-open-group
 nil server
-(save-excursion
+(with-current-buffer nntp-server-buffer
-(set-buffer nntp-server-buffer)
 (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)))
 (nntp-erase-buffer nntp-server-buffer)
 (nntp-send-string process last)))
 (defun nntp-make-process-buffer (buffer)
 "Create a new, fresh buffer usable for nntp process connections."
-(save-excursion
+(with-current-buffer
-(set-buffer
+(generate-new-buffer
-(generate-new-buffer
+(format " *server %s %s %s*"
-(format " *server %s %s %s*"
+nntp-address nntp-port-number
-	      nntp-address nntp-port-number
+(gnus-buffer-exists-p buffer)))
-	      (gnus-buffer-exists-p buffer))))
 (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)
 (set (make-local-variable 'nntp-process-to-buffer) nil)
 (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)
-	    (save-excursion
+	    (with-current-buffer pbuffer
-	      (set-buffer pbuffer)
 	      (nntp-read-server-type)
 	      (erase-buffer)
 	      (set-buffer nntp-server-buffer)
 	      (let ((nnheader-callback-function nil))
 		(run-hooks 'nntp-server-opened-hook)
 			      (format-spec nntp-ssl-program
 					   (format-spec-make
 					    ?s nntp-address
 					    ?p nntp-port-number)))))
 (gnus-set-process-query-on-exit-flag proc nil)
-(save-excursion
+(with-current-buffer buffer
-(set-buffer buffer)
 (let ((nntp-connection-alist (list proc buffer nil)))
 	(nntp-wait-for-string "^\r*20[01]"))
 (beginning-of-line)
 (delete-region (point-min) (point))
 proc)))
 (defun nntp-open-tls-stream (buffer)
 (let ((proc (open-tls-stream "nntpd" buffer nntp-address nntp-port-number)))
 (gnus-set-process-query-on-exit-flag proc nil)
-(save-excursion
+(with-current-buffer buffer
-(set-buffer buffer)
 (let ((nntp-connection-alist (list proc buffer nil)))
 	(nntp-wait-for-string "^\r*20[01]"))
 (beginning-of-line)
 (delete-region (point-min) (point))
 proc)))
 		 (not (eq 'lambda (caadr entry))))
 	    (eval (cadr entry))
 	  (funcall (cadr entry)))))))
 (defun nntp-async-wait (process wait-for buffer decode callback)
-(save-excursion
+(with-current-buffer (process-buffer process)
-(set-buffer (process-buffer process))
 (unless nntp-inside-change-function
 (erase-buffer))
 (setq nntp-process-wait-for wait-for
 	  nntp-process-to-buffer buffer
 	  nntp-process-decode decode
 ;; set to nil.  so we reset it here, if necessary.
 (when quit-flag
 (setq after-change-functions '(nntp-after-change-function)))))
 (defun nntp-async-trigger (process)
-(save-excursion
+(with-current-buffer (process-buffer process)
-(set-buffer (process-buffer process))
 (when nntp-process-callback
 ;; do we have an error message?
 (goto-char nntp-process-start-point)
 (if (memq (following-char) '(?4 ?5))
 	  ;; wants credentials?
 	  ;; convert it.
 	  (when (gnus-buffer-exists-p nntp-process-to-buffer)
 	    (let ((buf (current-buffer))
 		  (start nntp-process-start-point)
 		  (decode nntp-process-decode))
-	      (save-excursion
+	      (with-current-buffer nntp-process-to-buffer
-		(set-buffer nntp-process-to-buffer)
 		(goto-char (point-max))
 		(save-restriction
 		  (narrow-to-region (point) (point))
 		  (nntp-insert-buffer-substring buf start)
 		  (when decode
 (when group
 (let ((entry (nntp-find-connection-entry nntp-server-buffer)))
 (cond ((not entry)
 (nntp-report "Server closed connection"))
 ((not (equal group (caddr entry)))
-(save-excursion
+(with-current-buffer (process-buffer (car entry))
-(set-buffer (process-buffer (car entry)))
 (erase-buffer)
 (nntp-send-command "^[245].*\n" "GROUP" group)
 (setcar (cddr entry) group)
 (erase-buffer)
 	       (nntp-erase-buffer nntp-server-buffer)))))))
 (let ((commands nntp-xover-commands))
 	;; `nntp-xover-commands' is a list of possible XOVER commands.
 	;; We try them all until we get at positive response.
 	(while (and commands (eq nntp-server-xover 'try))
 	  (nntp-send-command-nodelete "\r?\n\\.\r?\n" (car commands) range)
-	  (save-excursion
+	  (with-current-buffer nntp-server-buffer
-	    (set-buffer nntp-server-buffer)
 	    (goto-char (point-min))
 	    (and (looking-at "[23]")	; No error message.
 		 ;; We also have to look at the lines.  Some buggy
 		 ;; servers give back simple lines with just the
 		 ;; article number.  How... helpful.
 nntp-server-xover))))
 (defun nntp-find-group-and-number (&optional group)
 (save-excursion
 (save-restriction
+;; FIXME: This is REALLY FISHY: set-buffer after save-restriction?!?
 (set-buffer nntp-server-buffer)
 (narrow-to-region (goto-char (point-min))
 			(or (search-forward "\n\n" nil t) (point-max)))
 (goto-char (point-min))
 ;; We first find the number by looking at the status line.
 ;; Replacements for the nntp-open-* functions -- drv
 ;; ==========================================================================
 (defun nntp-open-telnet-stream (buffer)
 "Open a nntp connection by telnet'ing the news server.
+`nntp-open-via-netcat' is recommended in place of this function
+because it is more reliable.
 Please refer to the following variables to customize the connection:
 - `nntp-pre-command',
 - `nntp-telnet-command',
 - `nntp-telnet-switches',
 		   ,nntp-address ,nntp-port-number))
 	proc)
 (and nntp-pre-command
 	 (push nntp-pre-command command))
 (setq proc (apply 'start-process "nntpd" buffer command))
-(save-excursion
+(with-current-buffer buffer
-(set-buffer buffer)
 (nntp-wait-for-string "^\r*20[01]")
 (beginning-of-line)
 (delete-region (point-min) (point))
 proc)))
 (defun nntp-open-via-rlogin-and-telnet (buffer)
 "Open a connection to an nntp server through an intermediate host.
 First rlogin to the remote host, and then telnet the real news server
 from there.
+`nntp-open-via-rlogin-and-netcat' is recommended in place of this function
+because it is more reliable.
 Please refer to the following variables to customize the connection:
 - `nntp-pre-command',
 - `nntp-via-rlogin-command',
 - `nntp-via-rlogin-command-switches',
 (setq command (append nntp-via-rlogin-command-switches command)))
 (push nntp-via-rlogin-command command)
 (and nntp-pre-command
 	 (push nntp-pre-command command))
 (setq proc (apply 'start-process "nntpd" buffer command))
-(save-excursion
+(with-current-buffer buffer
-(set-buffer buffer)
 (nntp-wait-for-string "^r?telnet")
 (process-send-string proc (concat "open " nntp-address
 					" " nntp-port-number "\n"))
 (nntp-wait-for-string "^\r*20[01]")
 (beginning-of-line)
 - `nntp-telnet-command',
 - `nntp-telnet-switches',
 - `nntp-address',
 - `nntp-port-number',
 - `nntp-end-of-line'."
-(save-excursion
+(with-current-buffer buffer
-(set-buffer buffer)
 (erase-buffer)
 (let ((command `(,nntp-via-telnet-command ,@nntp-via-telnet-switches))
 	  (case-fold-search t)
 	  proc)
 (and nntp-pre-command (push nntp-pre-command command))
 	(nnheader-message 7 "Bootstrapping marks for %s...done"
 			  decoded-name)))))
 (provide 'nntp)
-;;; arch-tag: 8655466a-b1b5-4929-9c45-7b1b2e767271
+;; arch-tag: 8655466a-b1b5-4929-9c45-7b1b2e767271
 ;;; nntp.el ends here

Mercurial > emacs

comparison lisp/gnus/nntp.el @ 92778:054fe9aaf3e3