;;; gnus-srvr.el --- virtual server support for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
%a agent covered
General format specifiers can also be used.
-See (gnus)Formatting Variables."
+See Info node `(gnus)Formatting Variables'."
:link '(custom-manual "(gnus)Formatting Variables")
:group 'gnus-server-visual
:type 'string)
"Whether server browsing should take place in the group buffer.
If nil, a faster, but more primitive, buffer is used instead."
:group 'gnus-server-visual
- :type 'string)
+ :type 'boolean)
;;; Internal variables.
(easy-menu-define
gnus-server-server-menu gnus-server-mode-map ""
'("Server"
- ["Add" gnus-server-add-server t]
+ ["Add..." gnus-server-add-server t]
["Browse" gnus-server-read-server t]
["Scan" gnus-server-scan-server t]
["List" gnus-server-list-servers t]
"(closed)")
((error) "(error)")))))
(gnus-tmp-agent (if (and gnus-agent
- (member method
- gnus-agent-covered-methods))
+ (gnus-agent-method-p method))
" (agent)"
"")))
(beginning-of-line)
(prog1 (1+ (point))
;; Insert the text.
(eval gnus-server-line-format-spec))
- (list 'gnus-server (intern gnus-tmp-name)))))
+ (list 'gnus-server (intern gnus-tmp-name)
+ 'gnus-named-server (intern (gnus-method-to-server method))))))
(defun gnus-enter-server-buffer ()
"Set up the server buffer."
(while alist
(unless (member (cdar alist) done)
(push (cdar alist) done)
- (cdr (setq server (pop alist)))
+ (setq server (pop alist))
(when (and server (car server) (cdr server))
(gnus-server-insert-server-line (car server) (cdr server))))
(when (member (cdar alist) done)
(gnus-server-position-point))
(defun gnus-server-server-name ()
- (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server)))
+ (let ((server (get-text-property (point-at-bol) 'gnus-server)))
+ (and server (symbol-name server))))
+
+(defun gnus-server-named-server ()
+ "Returns a server name that matches one of the names returned by
+gnus-method-to-server."
+ (let ((server (get-text-property (point-at-bol) 'gnus-named-server)))
(and server (symbol-name server))))
(defalias 'gnus-server-position-point 'gnus-goto-colon)
(when entry
(gnus-dribble-enter
(concat "(gnus-server-set-info \"" server "\" '"
- (prin1-to-string (cdr entry)) ")\n")))
+ (gnus-prin1-to-string (cdr entry)) ")\n")))
(when (or entry oentry)
;; Buffer may be narrowed.
(save-restriction
(when (and server info)
(gnus-dribble-enter
(concat "(gnus-server-set-info \"" server "\" '"
- (prin1-to-string info) ")"))
+ (gnus-prin1-to-string info) ")"))
(let* ((server (nth 1 info))
- (entry (assoc server gnus-server-alist)))
+ (entry (assoc server gnus-server-alist))
+ (cached (assoc server gnus-server-method-cache)))
+ (if cached
+ (setq gnus-server-method-cache
+ (delq cached gnus-server-method-cache)))
(if entry (setcdr entry info)
(setq gnus-server-alist
(nconc gnus-server-alist (list (cons server info))))))))
"Return to the group buffer."
(interactive)
(gnus-run-hooks 'gnus-server-exit-hook)
- (kill-buffer (current-buffer))
+ (gnus-kill-buffer (current-buffer))
(gnus-configure-windows 'group t))
(defun gnus-server-list-servers ()
"L" gnus-browse-exit
"q" gnus-browse-exit
"Q" gnus-browse-exit
+ "d" gnus-browse-describe-group
"\C-c\C-c" gnus-browse-exit
"?" gnus-browse-describe-briefly
["Subscribe" gnus-browse-unsubscribe-current-group t]
["Read" gnus-browse-read-group t]
["Select" gnus-browse-select-group t]
+ ["Describe" gnus-browse-describe-group t]
["Next" gnus-browse-next-group t]
["Prev" gnus-browse-prev-group t]
["Exit" gnus-browse-exit t]))
1 "Couldn't request list: %s" (gnus-status-message method))
nil)
(t
- (save-excursion
- (set-buffer nntp-server-buffer)
+ (with-current-buffer nntp-server-buffer
(let ((cur (current-buffer)))
(goto-char (point-min))
(unless (string= gnus-ignored-newsgroups "")
(delete-matching-lines gnus-ignored-newsgroups))
- (while (not (eobp))
- (ignore-errors
- (push (cons
- (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)
+ ;; 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
+ (buffer-substring
+ (point)
+ (progn
+ (skip-chars-forward "^ \t")
+ (point)))
+ (let ((last (read cur)))
+ (cons (read cur) last)))
+ groups))
+ (forward-line))
+ (while (not (eobp))
+ (ignore-errors
+ (push (cons
+ (if (eq (char-after) ?\")
+ (read cur)
+ (let ((p (point)) (name ""))
(skip-chars-forward "^ \t\\\\")
- (setq name (concat name (buffer-substring
- p (point)))))
- name))
- (let ((last (read cur)))
- (cons (read cur) last)))
- groups))
- (forward-line))))
+ (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))
+ (let ((last (read cur)))
+ (cons (read cur) last)))
+ groups))
+ (forward-line)))))
(setq groups (sort groups
(lambda (l1 l2)
(string< (car l1) (car l2)))))
(list
(format
"Gnus: %%b {%s:%s}" (car method) (cadr method))))
- (let ((buffer-read-only nil) charset
+ (let ((buffer-read-only nil)
+ name
(prefix (let ((gnus-select-method orig-select-method))
(gnus-group-prefixed-name "" method))))
- (while groups
- (setq group (car groups))
- (setq charset (gnus-group-name-charset method (car group)))
+ (while (setq group (pop groups))
(gnus-add-text-properties
(point)
(prog1 (1+ (point))
(insert
(format "%c%7d: %s\n"
- (let ((level (gnus-group-level (concat prefix (car group)))))
+ (let ((level (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)))
- (gnus-group-name-decode (car group) charset))))
- (list 'gnus-group (car group)))
- (setq groups (cdr groups))))
+ (mm-decode-coding-string
+ name
+ (inline (gnus-group-name-charset method name))))))
+ (list 'gnus-group name))))
(switch-to-buffer (current-buffer)))
(goto-char (point-min))
(gnus-group-position-point)
(if (or (not (gnus-get-info group))
(gnus-ephemeral-group-p group))
(unless (gnus-group-read-ephemeral-group
- (gnus-group-real-name group) gnus-browse-current-method nil
+ group gnus-browse-current-method nil
(cons (current-buffer) 'browse))
(error "Couldn't enter %s" group))
(unless (gnus-group-read-group nil no-article group)
(save-excursion
(beginning-of-line)
(let ((name (get-text-property (point) 'gnus-group)))
- (when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t)
- (gnus-group-prefixed-name
- (or name
- (match-string-no-properties 1))
- gnus-browse-current-method)))))
+ (when (re-search-forward ": \\(.*\\)$" (point-at-eol) t)
+ (concat (gnus-method-to-server-name gnus-browse-current-method) ":"
+ (or name
+ (match-string-no-properties 1)))))))
+
+(defun gnus-browse-describe-group (group)
+ "Describe the current group."
+ (interactive (list (gnus-browse-group-name)))
+ (gnus-group-describe-group nil group))
(defun gnus-browse-unsubscribe-group ()
"Toggle subscription of the current group in the browse buffer."
(unless (eq (char-after) ? )
(setq sub t))
(setq group (gnus-browse-group-name))
- ;;;;
- ;;(when (and sub
- ;; (cadr (gnus-gethash group gnus-newsrc-hashtb)))
- ;;(error "Group already subscribed"))
+ (when (gnus-server-equal gnus-browse-current-method "native")
+ (setq group (gnus-group-real-name group)))
(if sub
(progn
;; Make sure the group has been properly removed before we
"Quit browsing and return to the group buffer."
(interactive)
(when (eq major-mode 'gnus-browse-mode)
- (kill-buffer (current-buffer)))
+ (gnus-kill-buffer (current-buffer)))
;; Insert the newly subscribed groups in the group buffer.
(save-excursion
(set-buffer gnus-group-buffer)
projects / gnus / blobdiff