X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-srvr.el;h=98c24adc5f6224d93d11c544695ceb0775a371ab;hb=05e1ead695394f7d9fae8730e90e8db6dce2cc17;hp=9d5648f1ae20c94f031e756a3ede7e92b281ae17;hpb=315395e6852a4f03477d0faf8efc1ba59462fb6a;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-srvr.el b/lisp/gnus-srvr.el index 9d5648f..98c24ad 100644 --- a/lisp/gnus-srvr.el +++ b/lisp/gnus-srvr.el @@ -1,5 +1,5 @@ ;;; 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 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -34,10 +34,17 @@ (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. @@ -48,16 +55,24 @@ The following specs are understood: %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 (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 t - "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. @@ -106,6 +121,7 @@ The following specs are understood: '("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] @@ -139,6 +155,7 @@ The following specs are understood: "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 @@ -149,13 +166,82 @@ The following specs are understood: "\C-c\C-i" gnus-info-find-node "\C-c\C-b" gnus-bug)) +(defface gnus-server-agent-face + '((((class color) (background light)) (:foreground "PaleTurquoise" :bold t)) + (((class color) (background dark)) (:foreground "PaleTurquoise" :bold t)) + (t (:bold t))) + "Face used for displaying AGENTIZED servers" + :group 'gnus-server-visual) + +(defface gnus-server-opened-face + '((((class color) (background light)) (:foreground "Green3" :bold t)) + (((class color) (background dark)) (:foreground "Green1" :bold t)) + (t (:bold t))) + "Face used for displaying OPENED servers" + :group 'gnus-server-visual) + +(defface gnus-server-closed-face + '((((class color) (background light)) (:foreground "Steel Blue" :italic t)) + (((class color) (background dark)) + (:foreground "Light Steel Blue" :italic t)) + (t (:italic t))) + "Face used for displaying CLOSED servers" + :group 'gnus-server-visual) + +(defface gnus-server-denied-face + '((((class color) (background light)) (:foreground "Red" :bold t)) + (((class color) (background dark)) (:foreground "Pink" :bold t)) + (t (:inverse-video t :bold t))) + "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 + :type 'face) + +(defcustom gnus-server-opened-face 'gnus-server-opened-face + "Face name to use on OPENED servers." + :group 'gnus-server-visual + :type 'face) + +(defcustom gnus-server-closed-face 'gnus-server-closed-face + "Face name to use on CLOSED servers." + :group 'gnus-server-visual + :type 'face) + +(defcustom gnus-server-denied-face 'gnus-server-denied-face + "Face name to use on DENIED servers." + :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 () "Major mode for listing and editing servers. All normal editing commands are switched off. \\ For more in-depth information on this mode, read the manual -(`\\[gnus-info-find-node]'). +\(`\\[gnus-info-find-node]'). The following commands are available: @@ -173,23 +259,31 @@ The following commands are available: (buffer-disable-undo) (setq truncate-lines t) (setq buffer-read-only t) + (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-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)) - "(agent)" + " (agent)" ""))) (beginning-of-line) (gnus-add-text-properties @@ -286,7 +380,11 @@ The following commands are available: (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)))))))) @@ -338,7 +436,7 @@ The following commands are available: (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))) @@ -404,6 +502,18 @@ The following commands are available: (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) @@ -568,7 +678,7 @@ The following commands are available: ["Read" gnus-browse-read-group t] ["Select" gnus-browse-select-group t] ["Next" gnus-browse-next-group t] - ["Prev" gnus-browse-next-group t] + ["Prev" gnus-browse-prev-group t] ["Exit" gnus-browse-exit t])) (gnus-run-hooks 'gnus-browse-menu-hook))) @@ -641,7 +751,7 @@ The following commands are available: 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)) @@ -654,25 +764,23 @@ The following commands are available: (list (format "Gnus: %%b {%s:%s}" (car method) (cadr method)))) - (let ((buffer-read-only nil) charset) + (let ((buffer-read-only nil) charset + (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 group)) + (setq charset (gnus-group-name-charset method (car group))) (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))))) - (cond - ((<= level gnus-level-subscribed) ? ) - ((<= level gnus-level-unsubscribed) ?U) - ((= level gnus-level-zombie) ?Z) - (t ?K))) + (let ((level (gnus-group-level (concat prefix (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))) @@ -836,10 +944,10 @@ buffer. (unless server (error "No server on the current line")) (condition-case () - (gnus-get-function (gnus-server-to-method server) + (gnus-get-function (gnus-server-to-method server) 'request-regenerate) (error - (error "This backend doesn't support regeneration"))) + (error "This backend doesn't support regeneration"))) (gnus-message 5 "Requesting regeneration of %s..." server) (unless (gnus-open-server server) (error "Couldn't open server")) @@ -849,4 +957,4 @@ buffer. (provide 'gnus-srvr) -;;; gnus-srvr.el ends here. +;;; gnus-srvr.el ends here