Mercurial > hg > xemacs-beta

comparison lisp/gnus/nntp.el @ 32:e04119814345 r19-15b99

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b99
author cvs
date Mon, 13 Aug 2007 08:52:56 +0200
parents ec9a17fef872
children 8b8b7f3559a2
comparison
equal deleted inserted replaced
31:b9328a10c56c 32:e04119814345
167 (defvoo nntp-server-xover 'try) 167 (defvoo nntp-server-xover 'try)
168 (defvoo nntp-server-list-active-group 'try) 168 (defvoo nntp-server-list-active-group 'try)
169 169
170 (eval-and-compile 170 (eval-and-compile
171 (autoload 'nnmail-read-passwd "nnmail")) 171 (autoload 'nnmail-read-passwd "nnmail"))
172
173
174
175 ;;; Internal functions.
176
177 (defsubst nntp-send-string (process string)
178 "Send STRING to PROCESS."
179 (process-send-string process (concat string nntp-end-of-line)))
180
181 (defsubst nntp-wait-for (process wait-for buffer &optional decode discard)
182 "Wait for WAIT-FOR to arrive from PROCESS."
183 (save-excursion
184 (set-buffer (process-buffer process))
185 (goto-char (point-min))
186 (while (or (not (memq (following-char) '(?2 ?3 ?4 ?5)))
187 (looking-at "480"))
188 (when (looking-at "480")
189 (erase-buffer)
190 (funcall nntp-authinfo-function))
191 (nntp-accept-process-output process)
192 (goto-char (point-min)))
193 (prog1
194 (if (looking-at "[45]")
195 (progn
196 (nntp-snarf-error-message)
197 nil)
198 (goto-char (point-max))
199 (let ((limit (point-min)))
200 (while (not (re-search-backward wait-for limit t))
201 ;; We assume that whatever we wait for is less than 1000
202 ;; characters long.
203 (setq limit (max (- (point-max) 1000) (point-min)))
204 (nntp-accept-process-output process)
205 (goto-char (point-max))))
206 (nntp-decode-text (not decode))
207 (unless discard
208 (save-excursion
209 (set-buffer buffer)
210 (goto-char (point-max))
211 (insert-buffer-substring (process-buffer process))
212 ;; Nix out "nntp reading...." message.
213 (when nntp-have-messaged
214 (setq nntp-have-messaged nil)
215 (message ""))
216 t)))
217 (unless discard
218 (erase-buffer)))))
219
220 (defsubst nntp-find-connection (buffer)
221 "Find the connection delivering to BUFFER."
222 (let ((alist nntp-connection-alist)
223 (buffer (if (stringp buffer) (get-buffer buffer) buffer))
224 process entry)
225 (while (setq entry (pop alist))
226 (when (eq buffer (cadr entry))
227 (setq process (car entry)
228 alist nil)))
229 (when process
230 (if (memq (process-status process) '(open run))
231 process
232 (when (buffer-name (process-buffer process))
233 (kill-buffer (process-buffer process)))
234 (setq nntp-connection-alist (delq entry nntp-connection-alist))
235 nil))))
236
237 (defsubst nntp-find-connection-entry (buffer)
238 "Return the entry for the connection to BUFFER."
239 (assq (nntp-find-connection buffer) nntp-connection-alist))
240
241 (defun nntp-find-connection-buffer (buffer)
242 "Return the process connection buffer tied to BUFFER."
243 (let ((process (nntp-find-connection buffer)))
244 (when process
245 (process-buffer process))))
246
247 (defsubst nntp-retrieve-data (command address port buffer
248 &optional wait-for callback decode)
249 "Use COMMAND to retrieve data into BUFFER from PORT on ADDRESS."
250 (let ((process (or (nntp-find-connection buffer)
251 (nntp-open-connection buffer))))
252 (if (not process)
253 (nnheader-report 'nntp "Couldn't open connection to %s" address)
254 (unless (or nntp-inhibit-erase nnheader-callback-function)
255 (save-excursion
256 (set-buffer (process-buffer process))
257 (erase-buffer)))
258 (when command
259 (nntp-send-string process command))
260 (cond
261 ((eq callback 'ignore)
262 t)
263 ((and callback wait-for)
264 (save-excursion
265 (set-buffer (process-buffer process))
266 (unless nntp-inside-change-function
267 (erase-buffer))
268 (setq nntp-process-decode decode
269 nntp-process-to-buffer buffer
270 nntp-process-wait-for wait-for
271 nntp-process-callback callback
272 nntp-process-start-point (point-max)
273 after-change-functions
274 (list 'nntp-after-change-function-callback)))
275 t)
276 (wait-for
277 (nntp-wait-for process wait-for buffer decode))
278 (t t)))))
279
280 (defsubst nntp-send-command (wait-for &rest strings)
281 "Send STRINGS to server and wait until WAIT-FOR returns."
282 (when (and (not nnheader-callback-function)
283 (not nntp-inhibit-output))
284 (save-excursion
285 (set-buffer nntp-server-buffer)
286 (erase-buffer)))
287 (nntp-retrieve-data
288 (mapconcat 'identity strings " ")
289 nntp-address nntp-port-number nntp-server-buffer
290 wait-for nnheader-callback-function))
291
292 (defun nntp-send-command-nodelete (wait-for &rest strings)
293 "Send STRINGS to server and wait until WAIT-FOR returns."
294 (nntp-retrieve-data
295 (mapconcat 'identity strings " ")
296 nntp-address nntp-port-number nntp-server-buffer
297 wait-for nnheader-callback-function))
298
299 (defun nntp-send-command-and-decode (wait-for &rest strings)
300 "Send STRINGS to server and wait until WAIT-FOR returns."
301 (when (and (not nnheader-callback-function)
302 (not nntp-inhibit-output))
303 (save-excursion
304 (set-buffer nntp-server-buffer)
305 (erase-buffer)))
306 (nntp-retrieve-data
307 (mapconcat 'identity strings " ")
308 nntp-address nntp-port-number nntp-server-buffer
309 wait-for nnheader-callback-function t))
310
311 (defun nntp-send-buffer (wait-for)
312 "Send the current buffer to server and wait until WAIT-FOR returns."
313 (when (and (not nnheader-callback-function)
314 (not nntp-inhibit-output))
315 (save-excursion
316 (set-buffer (nntp-find-connection-buffer nntp-server-buffer))
317 (erase-buffer)))
318 (nntp-encode-text)
319 (process-send-region (nntp-find-connection nntp-server-buffer)
320 (point-min) (point-max))
321 (nntp-retrieve-data
322 nil nntp-address nntp-port-number nntp-server-buffer
323 wait-for nnheader-callback-function))
172 324
173 325
174 326
175 ;;; Interface functions. 327 ;;; Interface functions.
176 328
559 "^.*\r?\n" "AUTHINFO PASS" 711 "^.*\r?\n" "AUTHINFO PASS"
560 (buffer-substring (point) (progn (end-of-line) (point))))))) 712 (buffer-substring (point) (progn (end-of-line) (point)))))))
561 713
562 ;;; Internal functions. 714 ;;; Internal functions.
563 715
564 (defun nntp-send-command (wait-for &rest strings)
565 "Send STRINGS to server and wait until WAIT-FOR returns."
566 (when (and (not nnheader-callback-function)
567 (not nntp-inhibit-output))
568 (save-excursion
569 (set-buffer nntp-server-buffer)
570 (erase-buffer)))
571 (nntp-retrieve-data
572 (mapconcat 'identity strings " ")
573 nntp-address nntp-port-number nntp-server-buffer
574 wait-for nnheader-callback-function))
575
576 (defun nntp-send-command-nodelete (wait-for &rest strings)
577 "Send STRINGS to server and wait until WAIT-FOR returns."
578 (nntp-retrieve-data
579 (mapconcat 'identity strings " ")
580 nntp-address nntp-port-number nntp-server-buffer
581 wait-for nnheader-callback-function))
582
583 (defun nntp-send-command-and-decode (wait-for &rest strings)
584 "Send STRINGS to server and wait until WAIT-FOR returns."
585 (when (and (not nnheader-callback-function)
586 (not nntp-inhibit-output))
587 (save-excursion
588 (set-buffer nntp-server-buffer)
589 (erase-buffer)))
590 (nntp-retrieve-data
591 (mapconcat 'identity strings " ")
592 nntp-address nntp-port-number nntp-server-buffer
593 wait-for nnheader-callback-function t))
594
595 (defun nntp-send-buffer (wait-for)
596 "Send the current buffer to server and wait until WAIT-FOR returns."
597 (when (and (not nnheader-callback-function)
598 (not nntp-inhibit-output))
599 (save-excursion
600 (set-buffer (nntp-find-connection-buffer nntp-server-buffer))
601 (erase-buffer)))
602 (nntp-encode-text)
603 (process-send-region (nntp-find-connection nntp-server-buffer)
604 (point-min) (point-max))
605 (nntp-retrieve-data
606 nil nntp-address nntp-port-number nntp-server-buffer
607 wait-for nnheader-callback-function))
608
609 (defun nntp-find-connection (buffer)
610 "Find the connection delivering to BUFFER."
611 (let ((alist nntp-connection-alist)
612 (buffer (if (stringp buffer) (get-buffer buffer) buffer))
613 process entry)
614 (while (setq entry (pop alist))
615 (when (eq buffer (cadr entry))
616 (setq process (car entry)
617 alist nil)))
618 (when process
619 (if (memq (process-status process) '(open run))
620 process
621 (when (buffer-name (process-buffer process))
622 (kill-buffer (process-buffer process)))
623 (setq nntp-connection-alist (delq entry nntp-connection-alist))
624 nil))))
625
626 (defun nntp-find-connection-entry (buffer)
627 "Return the entry for the connection to BUFFER."
628 (assq (nntp-find-connection buffer) nntp-connection-alist))
629
630 (defun nntp-find-connection-buffer (buffer)
631 "Return the process connection buffer tied to BUFFER."
632 (let ((process (nntp-find-connection buffer)))
633 (when process
634 (process-buffer process))))
635
636 (defun nntp-make-process-buffer (buffer) 716 (defun nntp-make-process-buffer (buffer)
637 "Create a new, fresh buffer usable for nntp process connections." 717 "Create a new, fresh buffer usable for nntp process connections."
638 (save-excursion 718 (save-excursion
639 (set-buffer 719 (set-buffer
640 (generate-new-buffer 720 (generate-new-buffer
728 (nntp-inside-change-function t)) 808 (nntp-inside-change-function t))
729 (setq nntp-process-callback nil) 809 (setq nntp-process-callback nil)
730 (save-excursion 810 (save-excursion
731 (funcall callback (buffer-name 811 (funcall callback (buffer-name
732 (get-buffer nntp-process-to-buffer)))))))))) 812 (get-buffer nntp-process-to-buffer))))))))))
733
734 (defun nntp-retrieve-data (command address port buffer
735 &optional wait-for callback decode)
736 "Use COMMAND to retrieve data into BUFFER from PORT on ADDRESS."
737 (let ((process (or (nntp-find-connection buffer)
738 (nntp-open-connection buffer))))
739 (if (not process)
740 (nnheader-report 'nntp "Couldn't open connection to %s" address)
741 (unless (or nntp-inhibit-erase nnheader-callback-function)
742 (save-excursion
743 (set-buffer (process-buffer process))
744 (erase-buffer)))
745 (when command
746 (nntp-send-string process command))
747 (cond
748 ((eq callback 'ignore)
749 t)
750 ((and callback wait-for)
751 (save-excursion
752 (set-buffer (process-buffer process))
753 (unless nntp-inside-change-function
754 (erase-buffer))
755 (setq nntp-process-decode decode
756 nntp-process-to-buffer buffer
757 nntp-process-wait-for wait-for
758 nntp-process-callback callback
759 nntp-process-start-point (point-max)
760 after-change-functions
761 (list 'nntp-after-change-function-callback)))
762 t)
763 (wait-for
764 (nntp-wait-for process wait-for buffer decode))
765 (t t)))))
766
767 (defun nntp-send-string (process string)
768 "Send STRING to PROCESS."
769 (process-send-string process (concat string nntp-end-of-line)))
770
771 (defun nntp-wait-for (process wait-for buffer &optional decode discard)
772 "Wait for WAIT-FOR to arrive from PROCESS."
773 (save-excursion
774 (set-buffer (process-buffer process))
775 (goto-char (point-min))
776 (while (or (not (memq (following-char) '(?2 ?3 ?4 ?5)))
777 (looking-at "480"))
778 (when (looking-at "480")
779 (erase-buffer)
780 (funcall nntp-authinfo-function))
781 (nntp-accept-process-output process)
782 (goto-char (point-min)))
783 (prog1
784 (if (looking-at "[45]")
785 (progn
786 (nntp-snarf-error-message)
787 nil)
788 (goto-char (point-max))
789 (let ((limit (point-min)))
790 (while (not (re-search-backward wait-for limit t))
791 ;; We assume that whatever we wait for is less than 1000
792 ;; characters long.
793 (setq limit (max (- (point-max) 1000) (point-min)))
794 (nntp-accept-process-output process)
795 (goto-char (point-max))))
796 (nntp-decode-text (not decode))
797 (unless discard
798 (save-excursion
799 (set-buffer buffer)
800 (goto-char (point-max))
801 (insert-buffer-substring (process-buffer process))
802 ;; Nix out "nntp reading...." message.
803 (when nntp-have-messaged
804 (setq nntp-have-messaged nil)
805 (message ""))
806 t)))
807 (unless discard
808 (erase-buffer)))))
809 813
810 (defun nntp-snarf-error-message () 814 (defun nntp-snarf-error-message ()
811 "Save the error message in the current buffer." 815 "Save the error message in the current buffer."
812 (let ((message (buffer-string))) 816 (let ((message (buffer-string)))
813 (while (string-match "[\r\n]+" message) 817 (while (string-match "[\r\n]+" message)