xemacs-beta: lisp/gnus/nntp.el comparison

comparison lisp/gnus/nntp.el @ 30:ec9a17fef872 r19-15b98

Import from CVS: tag r19-15b98

author	cvs
date	Mon, 13 Aug 2007 08:52:29 +0200
parents	441bb1e64a06
children	e04119814345

comparison

equal deleted inserted replaced

-:7976500f47f9
+:ec9a17fef872
 (defvoo nntp-port-number "nntp"
 "Port number on the physical nntp server.")
 (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
 server spawn an nnrpd server.  Another useful function to put in this
 hook might be `nntp-send-authinfo', which will prompt for a password
 to allow posting from the server.  Note that this is only necessary to
 do on servers that use strict access control.")
 (defvoo nntp-authinfo-function 'nntp-send-authinfo
 "Function used to send AUTHINFO to the server.")
 (defvoo nntp-server-action-alist
 '(("nntpd 1\\.5\\.11t"
 (remove-hook 'nntp-server-opened-hook 'nntp-send-mode-reader))
 ("NNRP server Netscape"
 (setq nntp-server-list-active-group nil)))
 "Alist of regexps to match on server types and actions to be taken.
 For instance, if you want Gnus to beep every time you connect
 to innd, you could say something like:
 	     (not nntp-nov-is-evil)
 	     (nntp-retrieve-headers-with-xover articles fetch-old))
 	;; We successfully retrieved the headers via XOVER.
 'nov
 ;; XOVER didn't work, so we do it the hard, slow and inefficient
 ;; way.
 (let ((number (length articles))
 	    (count 0)
 	    (received 0)
 	    (last-point (point-min))
 	    (buf (nntp-find-connection-buffer nntp-server-buffer))
 	    (nntp-inhibit-erase t))
 	;; Send HEAD command.
 	(while articles
 	  (nntp-send-command
 	   nil
 	   "HEAD" (if (numberp (car articles))
 		      (int-to-string (car articles))
 		    ;; `articles' is either a list of article numbers
 		    ;; or a list of article IDs.
 "Retrieve group info on GROUPS."
 (nntp-possibly-change-group nil server)
 (save-excursion
 (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)
 	  article alist)
 (set-buffer buf)
 (erase-buffer)
 ;; Send HEAD command.
 (while (setq article (pop articles))
 	(nntp-send-command
 	 nil
 	 "ARTICLE" (if (numberp article)
 		       (int-to-string article)
 		     ;; `articles' is either a list of article numbers
 		     ;; or a list of article IDs.
 	 (cons (car entry) point))
 map))))
 (defun nntp-next-result-arrived-p ()
 (let ((point (point)))
 (cond
 ((looking-at "2")
 (if (re-search-forward "\n.\r?\n" nil t)
 	  t
 	(goto-char point)
 	nil))
 (let* ((date (timezone-parse-date date))
 	   (time-string
 	    (format "%s%02d%02d %s%s%s"
 		    (substring (aref date 0) 2) (string-to-int (aref date 1))
 		    (string-to-int (aref date 2)) (substring (aref date 3) 0 2)
 		    (substring
 		     (aref date 3) 3 5) (substring (aref date 3) 6 8))))
 (prog1
 	  (nntp-send-command "^\\.\r?\n" "NEWGROUPS" time-string)
 	(nntp-decode-text)))))
 (when (nntp-send-command "^[23].*\r?\n" "POST")
 (nntp-send-buffer "^[23].*\n")))
 (deffoo nntp-request-type (group article)
 'news)
 (deffoo nntp-asynchronous-p ()
 t)
 ;;; Hooky functions.
 (defun nntp-send-nosy-authinfo ()
 "Send the AUTHINFO to the nntp server.
 This function is supposed to be called from `nntp-server-opened-hook'.
 It will prompt for a password."
 (nntp-send-command
 "^.*\r?\n" "AUTHINFO USER"
 (read-string (format "NNTP (%s) user name: " nntp-address)))
 (nntp-send-command
 "^.*\r?\n" "AUTHINFO PASS"
 (nnmail-read-passwd "NNTP (%s) password: " nntp-address)))
 (defun nntp-send-authinfo ()
 "Send the AUTHINFO to the nntp server.
 This function is supposed to be called from `nntp-server-opened-hook'.
 It will prompt for a password."
 (nntp-send-command "^.*\r?\n" "AUTHINFO USER" (user-login-name))
 (nntp-send-command
 "^.*\r?\n" "AUTHINFO PASS"
 (nnmail-read-passwd (format "NNTP (%s) password: " nntp-address))))
 (defun nntp-send-authinfo-from-file ()
 "Send the AUTHINFO to the nntp server.
 This function is supposed to be called from `nntp-server-opened-hook'."
 (when (file-exists-p "~/.nntp-authinfo")
 (nnheader-temp-write nil
 (insert-file-contents "~/.nntp-authinfo")
 (goto-char (point-min))
 (nntp-send-command "^.*\r?\n" "AUTHINFO USER" (user-login-name))
 (nntp-send-command
 "^.*\r?\n" "AUTHINFO PASS"
 (buffer-substring (point) (progn (end-of-line) (point)))))))
 ;;; Internal functions.
 (defun nntp-send-command (wait-for &rest strings)
 (process-buffer process))))
 (defun nntp-make-process-buffer (buffer)
 "Create a new, fresh buffer usable for nntp process connections."
 (save-excursion
 (set-buffer
 (generate-new-buffer
 (format " *server %s %s %s*"
 	      nntp-address nntp-port-number
 	      (buffer-name (get-buffer buffer)))))
 (buffer-disable-undo (current-buffer))
 	(save-excursion
 	  (set-buffer (process-buffer process))
 	  (erase-buffer)))
 (when command
 	(nntp-send-string process command))
 (cond
 ((eq callback 'ignore)
 	t)
 ((and callback wait-for)
 	(save-excursion
 	  (set-buffer (process-buffer process))
 	  (unless nntp-inside-change-function
 	    (erase-buffer))
 	  (setq nntp-process-decode decode
 		nntp-process-to-buffer buffer
 		nntp-process-wait-for wait-for
 		nntp-process-callback callback
 		nntp-process-start-point (point-max)
 		after-change-functions
 		(list 'nntp-after-change-function-callback)))
 	t)
 (wait-for
 	(nntp-wait-for process wait-for buffer decode))
 (t t)))))
 (defun nntp-send-string (process string)
 "Send STRING to PROCESS."
 	      (nntp-snarf-error-message)
 	      nil)
 	  (goto-char (point-max))
 	  (let ((limit (point-min)))
 	    (while (not (re-search-backward wait-for limit t))
 	      ;; We assume that whatever we wait for is less than 1000
 	      ;; characters long.
 	      (setq limit (max (- (point-max) 1000) (point-min)))
 	      (nntp-accept-process-output process)
 	      (goto-char (point-max))))
 	  (nntp-decode-text (not decode))
 (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))
-(let ((len (/ (point-max) 1024)))
+(let ((len (/ (point-max) 1024))
+	  message-log-max)
 (unless (< len 10)
 	(setq nntp-have-messaged t)
 	(nnheader-message 7 "nntp read: %dk" len)))
 (accept-process-output process 1)))
 (insert "." nntp-end-of-line)))
 (defun nntp-retrieve-headers-with-xover (articles &optional fetch-old)
 (set-buffer nntp-server-buffer)
 (erase-buffer)
 (cond
 ;; This server does not talk NOV.
 ((not nntp-server-xover)
 nil)
 ;; We don't care about gaps.
 ((or (not nntp-nov-gap)
 	fetch-old)
 (nntp-send-xover-command
 (if fetch-old
 	 (if (numberp fetch-old)
 	     (max 1 (- (car articles) fetch-old))
 	   1)
 (car articles))
 ;; that means that the server does not understand XOVER, but we
 ;; won't know that until we try.
 (while (and nntp-server-xover articles)
 	(setq first (car articles))
 	;; Search forward until we find a gap, or until we run out of
 	;; articles.
 	(while (and (cdr articles)
 		    (< (- (nth 1 articles) (car articles)) nntp-nov-gap))
 	  (setq articles (cdr articles)))
 	(when (nntp-send-xover-command first (car articles))
 		    (zerop (% count nntp-maximum-request)))
 	    (accept-process-output)
 	    ;; On some Emacs versions the preceding function has
 	    ;; a tendency to change the buffer.  Perhaps.  It's
 	    ;; quite difficult to reproduce, because it only
 	    ;; seems to happen once in a blue moon.
 	    (set-buffer buf)
 	    (while (progn
 		     (goto-char last-point)
 		     ;; Count replies.
 		     (while (re-search-forward "^[0-9][0-9][0-9] " nil t)
 	  (while (progn
 		   (goto-char (point-max))
 		   (forward-line -1)
 		   (not (looking-at "^\\.\r?\n")))
 	    (nntp-accept-response)))
 	;; We remove any "." lines and status lines.
 	(goto-char (point-min))
 	(while (search-forward "\r" nil t)
 	  (delete-char -1))
 	(goto-char (point-min))
 	(nntp-inhibit-erase t))
 (if (stringp nntp-server-xover)
 	;; If `nntp-server-xover' is a string, then we just send this
 	;; command.
 	(if wait-for-reply
 	    (nntp-send-command-nodelete
 	     "\r?\n\\.\r?\n" nntp-server-xover range)
 	  ;; We do not wait for the reply.
 	  (nntp-send-command-nodelete "\r?\n\\.\r?\n" nntp-server-xover range))
 (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
 	    (set-buffer nntp-server-buffer)
 	    (goto-char (point-min))
 					    (match-end 1)))))
 	    group newsgroups xref)
 	(and number (zerop number) (setq number nil))
 	;; Then we find the group name.
 	(setq group
 	      (cond
 	       ;; If there is only one group in the Newsgroups header,
 	       ;; then it seems quite likely that this article comes
 	       ;; from that group, I'd say.
 	       ((and (setq newsgroups (mail-fetch-field "newsgroups"))
 		     (not (string-match "," newsgroups)))
 	       ;; header, then the Xref header should be filled out.
 	       ;; We hazard a guess that the group that has this
 	       ;; article number in the Xref header is the one we are
 	       ;; looking for.  This might very well be wrong if this
 	       ;; article happens to have the same number in several
 	       ;; groups, but that's life.
 	       ((and (setq xref (mail-fetch-field "xref"))
 		     number
 		     (string-match (format "\\([^ :]+\\):%d" number) xref))
 		(substring xref (match-beginning 1) (match-end 1)))
 	       (t "")))

Mercurial > hg > xemacs-beta

comparison lisp/gnus/nntp.el @ 30:ec9a17fef872 r19-15b98