X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-srvr.el;h=77596eadded3fc41c1bc9a378141f1d6994c333c;hb=a0a93f566435dea7fa280a074b9ec950b84dbdd5;hp=437889473a7c5f2f13c647f962b6d8f5b515f3ee;hpb=52823b7763f961c511d12b0ae72bcad39c5c6acb;p=gnus diff --git a/lisp/gnus-srvr.el b/lisp/gnus-srvr.el index 437889473..77596eadd 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, 2003 ;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen @@ -57,8 +57,9 @@ The following specs are understood: %s status %a agent covered -General format specifiers can also be used. See -(gnus)Formatting Variables." +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) @@ -71,7 +72,7 @@ General format specifiers can also be used. See "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. @@ -104,7 +105,7 @@ If nil, a faster, but more primitive, buffer is used instead." (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] @@ -120,6 +121,7 @@ If nil, a faster, but more primitive, buffer is used instead." '("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] @@ -153,6 +155,7 @@ If nil, a faster, but more primitive, buffer is used instead." "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 @@ -192,6 +195,13 @@ If nil, a faster, but more primitive, buffer is used instead." "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 @@ -212,11 +222,17 @@ If nil, a faster, but more primitive, buffer is used instead." :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 () @@ -246,22 +262,24 @@ 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 - (if (eq (nth 1 elem) 'denied) - "(denied)" - (condition-case nil - (if (or (gnus-server-opened method) - (eq (nth 1 elem) 'ok)) + (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)")))) + "(closed)") + ((error) "(error)"))))) (gnus-tmp-agent (if (and gnus-agent (member method gnus-agent-covered-methods)) @@ -303,7 +321,7 @@ The following commands are available: (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) @@ -341,7 +359,7 @@ The following commands are available: (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 @@ -360,9 +378,13 @@ The following commands are available: (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)))))))) @@ -414,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))) @@ -423,7 +445,7 @@ The following commands are available: "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 () @@ -480,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) @@ -628,6 +662,7 @@ The following commands are available: "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 @@ -643,6 +678,7 @@ The following commands are available: ["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])) @@ -730,27 +766,28 @@ 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) + 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) @@ -844,6 +881,11 @@ buffer. (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) @@ -855,10 +897,6 @@ 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")) (if sub (progn ;; Make sure the group has been properly removed before we @@ -888,7 +926,7 @@ buffer. "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)