Function: gnus-browse-foreign-server

gnus-browse-foreign-server is an autoloaded and byte-compiled function defined in gnus-srvr.el.gz.

Signature

(gnus-browse-foreign-server SERVER &optional RETURN-BUFFER)

Documentation

Browse the server SERVER.

Source Code

;; Defined in /usr/src/emacs/lisp/gnus/gnus-srvr.el.gz
(defun gnus-browse-foreign-server (server &optional return-buffer)
  "Browse the server SERVER."
  (setq gnus-browse-current-method (gnus-server-to-method server))
  (setq gnus-browse-return-buffer return-buffer)
  (let* ((method gnus-browse-current-method)
	 (orig-select-method gnus-select-method)
	 (gnus-select-method method)
	 groups group)
    (gnus-message 5 "Connecting to %s..." (nth 1 method))
    (cond
     ((not (gnus-check-server method))
      (gnus-message
       1 "Unable to contact server %s: %s" (nth 1 method)
       (gnus-status-message method))
      nil)
     ((not
       (prog2
	   (gnus-message 6 "Reading active file...")
	   (gnus-request-list method)
	 (gnus-message 6 "Reading active file...done")))
      (gnus-message
       1 "Couldn't request list: %s" (gnus-status-message method))
      nil)
     (t
      (with-current-buffer nntp-server-buffer
	(let ((cur (current-buffer)))
	  (goto-char (point-min))
         (unless (or (null gnus-ignored-newsgroups)
                     (string= gnus-ignored-newsgroups ""))
	    (delete-matching-lines gnus-ignored-newsgroups))
	  ;; We treat NNTP as a special case to avoid problems with
	  ;; garbage group names like `"foo' that appear in some badly
	  ;; managed active files. -jh.
	  (if (eq (car method) 'nntp)
	      (while (not (eobp))
		(ignore-errors
		  (push (cons
			 (decode-coding-string
			  (buffer-substring
			   (point)
			   (progn
			     (skip-chars-forward "^ \t")
			     (point)))
			  'utf-8-emacs)
			 (let ((last (read cur)))
			   (cons (read cur) last)))
			groups))
		(forward-line))
	    (while (not (eobp))
	      (ignore-errors
		(push (cons
		       (decode-coding-string
			(if (eq (char-after) ?\")
			    (read cur)
			  (let ((p (point)) (name ""))
			    (skip-chars-forward "^ \t\\\\")
			    (setq name (buffer-substring p (point)))
			    (while (eq (char-after) ?\\)
			      (setq p (1+ (point)))
			      (forward-char 2)
			      (skip-chars-forward "^ \t\\\\")
			      (setq name (concat name (buffer-substring
						       p (point)))))
			    name))
			'utf-8-emacs)
		       (let ((last (read cur)))
			 (cons (read cur) last)))
		      groups))
	      (forward-line)))))
      (setq groups (sort groups
			 (lambda (l1 l2)
			   (string< (car l1) (car l2)))))
      (if gnus-server-browse-in-group-buffer
	  (let* ((gnus-select-method orig-select-method)
		 (gnus-group-listed-groups
		  (mapcar (lambda (group)
			    (let ((name
				   (gnus-group-prefixed-name
				    (car group) method)))
			      (gnus-set-active name (cdr group))
			      name))
			  groups)))
	    (gnus-configure-windows 'group)
	    (funcall gnus-group-prepare-function
		     gnus-level-killed 'ignore 1 'ignore))
	(gnus-get-buffer-create gnus-browse-buffer)
	(gnus-configure-windows 'browse)
	(buffer-disable-undo)
	(let ((buffer-read-only nil))
	  (erase-buffer))
	(gnus-browse-mode)
	(setq mode-line-buffer-identification
	      (list
	       (format
		"Gnus: %%b {%s:%s}" (car method) (cadr method))))
	(let ((buffer-read-only nil)
	      name
	      (prefix (let ((gnus-select-method orig-select-method))
			(gnus-group-prefixed-name "" method))))
	  (while (setq group (pop groups))
	    (add-text-properties
	     (point)
	     (prog1 (1+ (point))
	       (insert
		(format "%c%7d: %s\n"
			(let ((level
			       (if (string= prefix "")
				   (gnus-group-level (setq name (car group)))
				 (gnus-group-level
				  (concat prefix (setq name (car group)))))))
			  (cond
			   ((<= level gnus-level-subscribed) ? )
			   ((<= level gnus-level-unsubscribed) ?U)
			   ((= level gnus-level-zombie) ?Z)
			   (t ?K)))
			(max 0 (- (1+ (cddr group)) (cadr group)))
			name)))
	     (list 'gnus-group name)
	     )))
	(switch-to-buffer (current-buffer)))
      (goto-char (point-min))
      (gnus-group-position-point)
      (gnus-message 5 "Connecting to %s...done" (nth 1 method))
      t))))