;;; gnus-srvr.el --- virtual server support for Gnus
-;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
+;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
(require 'gnus-int)
(require 'gnus-range)
-(defvar gnus-server-mode-hook nil
- "Hook run in `gnus-server-mode' buffers.")
+(defcustom gnus-server-mode-hook nil
+ "Hook run in `gnus-server-mode' buffers."
+ :group 'gnus-server
+ :type 'hook)
-(defconst gnus-server-line-format " {%(%h:%w%)} %s%a\n"
+(defcustom gnus-server-exit-hook nil
+ "Hook run when exiting the server buffer."
+ :group 'gnus-server
+ :type 'hook)
+
+(defcustom gnus-server-line-format " {%(%h:%w%)} %s%a\n"
"Format of server lines.
It works along the same lines as a normal formatting string,
with some simple extensions.
%n name
%w address
%s status
-%a agent covered")
+%a agent covered
-(defvar gnus-server-mode-line-format "Gnus: %%b"
- "The format specification for the server mode line.")
+General format specifiers can also be used.
+See Info node `(gnus)Formatting Variables'."
+ :link '(custom-manual "(gnus)Formatting Variables")
+ :group 'gnus-server-visual
+ :type 'string)
-(defvar gnus-server-exit-hook nil
- "*Hook run when exiting the server buffer.")
+(defcustom gnus-server-mode-line-format "Gnus: %%b"
+ "The format specification for the server mode line."
+ :group 'gnus-server-visual
+ :type 'string)
-(defvar gnus-server-browse-in-group-buffer nil
- "Whether browse server in group buffer.")
+(defcustom gnus-server-browse-in-group-buffer nil
+ "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 '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]
'("Connections"
["Open" gnus-server-open-server t]
["Close" gnus-server-close-server t]
+ ["Offline" gnus-server-offline-server t]
["Deny" gnus-server-deny-server t]
"---"
["Open All" gnus-server-open-all-servers t]
"C" gnus-server-close-server
"\M-c" gnus-server-close-all-servers
"D" gnus-server-deny-server
+ "L" gnus-server-offline-server
"R" gnus-server-remove-denials
"n" next-line
"Face used for displaying DENIED servers"
:group 'gnus-server-visual)
+(defface gnus-server-offline-face
+ '((((class color) (background light)) (:foreground "Orange" :bold t))
+ (((class color) (background dark)) (:foreground "Yellow" :bold t))
+ (t (:inverse-video t :bold t)))
+ "Face used for displaying OFFLINE servers"
+ :group 'gnus-server-visual)
+
(defcustom gnus-server-agent-face 'gnus-server-agent-face
"Face name to use on AGENTIZED servers."
:group 'gnus-server-visual
:group 'gnus-server-visual
:type 'face)
+(defcustom gnus-server-offline-face 'gnus-server-offline-face
+ "Face name to use on OFFLINE servers."
+ :group 'gnus-server-visual
+ :type 'face)
+
(defvar gnus-server-font-lock-keywords
(list
'("(\\(agent\\))" 1 gnus-server-agent-face)
'("(\\(opened\\))" 1 gnus-server-opened-face)
'("(\\(closed\\))" 1 gnus-server-closed-face)
+ '("(\\(offline\\))" 1 gnus-server-offline-face)
'("(\\(denied\\))" 1 gnus-server-denied-face)))
(defun gnus-server-mode ()
All normal editing commands are switched off.
\\<gnus-server-mode-map>
For more in-depth information on this mode, read the manual
-(`\\[gnus-info-find-node]').
+\(`\\[gnus-info-find-node]').
The following commands are available:
(if (featurep 'xemacs)
(put 'gnus-server-mode 'font-lock-defaults '(gnus-server-font-lock-keywords t))
(set (make-local-variable 'font-lock-defaults)
- '(gnus-server-font-lock-keywords t)))
+ '(gnus-server-font-lock-keywords t)))
(gnus-run-hooks 'gnus-server-mode-hook))
(defun gnus-server-insert-server-line (gnus-tmp-name method)
(let* ((gnus-tmp-how (car method))
(gnus-tmp-where (nth 1 method))
(elem (assoc method gnus-opened-servers))
- (gnus-tmp-status (cond ((eq (nth 1 elem) 'denied)
- "(denied)")
- ((or (gnus-server-opened method)
- (eq (nth 1 elem) 'ok))
- "(opened)")
- (t
- "(closed)")))
+ (gnus-tmp-status
+ (cond
+ ((eq (nth 1 elem) 'denied) "(denied)")
+ ((eq (nth 1 elem) 'offline) "(offline)")
+ (t
+ (condition-case nil
+ (if (or (gnus-server-opened method)
+ (eq (nth 1 elem) 'ok))
+ "(opened)"
+ "(closed)")
+ ((error) "(error)")))))
(gnus-tmp-agent (if (and gnus-agent
(member method
gnus-agent-covered-methods))
(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)
(concat "(gnus-server-set-info \"" server "\" '"
(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))))))))
(setq alist (cdr alist)))
(if alist
(setcdr alist (cons killed (cdr alist)))
- (setq gnus-server-alist (list killed)))))
+ (setq gnus-server-alist (list killed)))))
(gnus-server-update-server (car killed))
(setq gnus-server-killed-servers (cdr gnus-server-killed-servers))
(gnus-server-position-point)))
(gnus-server-update-server server)
(gnus-server-position-point))))
+(defun gnus-server-offline-server (server)
+ "Set SERVER to offline."
+ (interactive (list (gnus-server-server-name)))
+ (let ((method (gnus-server-to-method server)))
+ (unless method
+ (error "No such server: %s" server))
+ (prog1
+ (gnus-close-server method)
+ (gnus-server-set-status method 'offline)
+ (gnus-server-update-server server)
+ (gnus-server-position-point))))
+
(defun gnus-server-close-all-servers ()
"Close all servers."
(interactive)
"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-groups t]
["Next" gnus-browse-next-group t]
["Prev" gnus-browse-prev-group t]
["Exit" gnus-browse-exit t]))
groups)))
(gnus-configure-windows 'group)
(funcall gnus-group-prepare-function
- gnus-level-killed 'ignore 1 'ingore))
+ gnus-level-killed 'ignore 1 'ignore))
(gnus-get-buffer-create gnus-browse-buffer)
(when gnus-carpal
(gnus-carpal-setup-buffer 'browse))
(list
(format
"Gnus: %%b {%s:%s}" (car method) (cadr method))))
- (let ((buffer-read-only nil) charset)
- (while groups
- (setq group (car groups))
- (setq charset (gnus-group-name-charset method group))
+ (let ((buffer-read-only nil)
+ name
+ (prefix (let ((gnus-select-method orig-select-method))
+ (gnus-group-prefixed-name "" method))))
+ (while (setq group (pop groups))
(gnus-add-text-properties
(point)
(prog1 (1+ (point))
(insert
(format "%c%7d: %s\n"
- (let ((level
- (let ((gnus-select-method orig-select-method))
- (gnus-group-level
- (gnus-group-prefixed-name (car group)
- method)))))
+ (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)
(match-string-no-properties 1))
gnus-browse-current-method)))))
+(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."
(let ((sub nil)
(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"))
(if sub
(progn
;; Make sure the group has been properly removed before we
projects / gnus / blobdiff