1 ;;; gnus-srvr.el --- virtual server support for Gnus
2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
3 ;; Free Software Foundation, Inc.
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
23 ;; Boston, MA 02111-1307, USA.
29 (eval-when-compile (require 'cl))
37 (defcustom gnus-server-mode-hook nil
38 "Hook run in `gnus-server-mode' buffers."
42 (defcustom gnus-server-exit-hook nil
43 "Hook run when exiting the server buffer."
47 (defcustom gnus-server-line-format " {%(%h:%w%)} %s%a\n"
48 "Format of server lines.
49 It works along the same lines as a normal formatting string,
50 with some simple extensions.
52 The following specs are understood:
60 General format specifiers can also be used.
61 See (gnus)Formatting Variables."
62 :link '(custom-manual "(gnus)Formatting Variables")
63 :group 'gnus-server-visual
66 (defcustom gnus-server-mode-line-format "Gnus: %%b"
67 "The format specification for the server mode line."
68 :group 'gnus-server-visual
71 (defcustom gnus-server-browse-in-group-buffer nil
72 "Whether server browsing should take place in the group buffer.
73 If nil, a faster, but more primitive, buffer is used instead."
74 :group 'gnus-server-visual
77 ;;; Internal variables.
79 (defvar gnus-inserted-opened-servers nil)
81 (defvar gnus-server-line-format-alist
82 `((?h gnus-tmp-how ?s)
84 (?w gnus-tmp-where ?s)
85 (?s gnus-tmp-status ?s)
86 (?a gnus-tmp-agent ?s)))
88 (defvar gnus-server-mode-line-format-alist
89 `((?S gnus-tmp-news-server ?s)
90 (?M gnus-tmp-news-method ?s)
91 (?u gnus-tmp-user-defined ?s)))
93 (defvar gnus-server-line-format-spec nil)
94 (defvar gnus-server-mode-line-format-spec nil)
95 (defvar gnus-server-killed-servers nil)
97 (defvar gnus-server-mode-map)
99 (defvar gnus-server-menu-hook nil
100 "*Hook run after the creation of the server mode menu.")
102 (defun gnus-server-make-menu-bar ()
103 (gnus-turn-off-edit-menu 'server)
104 (unless (boundp 'gnus-server-server-menu)
106 gnus-server-server-menu gnus-server-mode-map ""
108 ["Add" gnus-server-add-server t]
109 ["Browse" gnus-server-read-server t]
110 ["Scan" gnus-server-scan-server t]
111 ["List" gnus-server-list-servers t]
112 ["Kill" gnus-server-kill-server t]
113 ["Yank" gnus-server-yank-server t]
114 ["Copy" gnus-server-copy-server t]
115 ["Edit" gnus-server-edit-server t]
116 ["Regenerate" gnus-server-regenerate-server t]
117 ["Exit" gnus-server-exit t]))
120 gnus-server-connections-menu gnus-server-mode-map ""
122 ["Open" gnus-server-open-server t]
123 ["Close" gnus-server-close-server t]
124 ["Offline" gnus-server-offline-server t]
125 ["Deny" gnus-server-deny-server t]
127 ["Open All" gnus-server-open-all-servers t]
128 ["Close All" gnus-server-close-all-servers t]
129 ["Reset All" gnus-server-remove-denials t]))
131 (gnus-run-hooks 'gnus-server-menu-hook)))
133 (defvar gnus-server-mode-map nil)
134 (put 'gnus-server-mode 'mode-class 'special)
136 (unless gnus-server-mode-map
137 (setq gnus-server-mode-map (make-sparse-keymap))
138 (suppress-keymap gnus-server-mode-map)
140 (gnus-define-keys gnus-server-mode-map
141 " " gnus-server-read-server-in-server-buffer
142 "\r" gnus-server-read-server
143 gnus-mouse-2 gnus-server-pick-server
145 "l" gnus-server-list-servers
146 "k" gnus-server-kill-server
147 "y" gnus-server-yank-server
148 "c" gnus-server-copy-server
149 "a" gnus-server-add-server
150 "e" gnus-server-edit-server
151 "s" gnus-server-scan-server
153 "O" gnus-server-open-server
154 "\M-o" gnus-server-open-all-servers
155 "C" gnus-server-close-server
156 "\M-c" gnus-server-close-all-servers
157 "D" gnus-server-deny-server
158 "L" gnus-server-offline-server
159 "R" gnus-server-remove-denials
164 "g" gnus-server-regenerate-server
166 "\C-c\C-i" gnus-info-find-node
167 "\C-c\C-b" gnus-bug))
169 (defface gnus-server-agent-face
170 '((((class color) (background light)) (:foreground "PaleTurquoise" :bold t))
171 (((class color) (background dark)) (:foreground "PaleTurquoise" :bold t))
173 "Face used for displaying AGENTIZED servers"
174 :group 'gnus-server-visual)
176 (defface gnus-server-opened-face
177 '((((class color) (background light)) (:foreground "Green3" :bold t))
178 (((class color) (background dark)) (:foreground "Green1" :bold t))
180 "Face used for displaying OPENED servers"
181 :group 'gnus-server-visual)
183 (defface gnus-server-closed-face
184 '((((class color) (background light)) (:foreground "Steel Blue" :italic t))
185 (((class color) (background dark))
186 (:foreground "Light Steel Blue" :italic t))
188 "Face used for displaying CLOSED servers"
189 :group 'gnus-server-visual)
191 (defface gnus-server-denied-face
192 '((((class color) (background light)) (:foreground "Red" :bold t))
193 (((class color) (background dark)) (:foreground "Pink" :bold t))
194 (t (:inverse-video t :bold t)))
195 "Face used for displaying DENIED servers"
196 :group 'gnus-server-visual)
198 (defface gnus-server-offline-face
199 '((((class color) (background light)) (:foreground "Orange" :bold t))
200 (((class color) (background dark)) (:foreground "Yellow" :bold t))
201 (t (:inverse-video t :bold t)))
202 "Face used for displaying OFFLINE servers"
203 :group 'gnus-server-visual)
205 (defcustom gnus-server-agent-face 'gnus-server-agent-face
206 "Face name to use on AGENTIZED servers."
207 :group 'gnus-server-visual
210 (defcustom gnus-server-opened-face 'gnus-server-opened-face
211 "Face name to use on OPENED servers."
212 :group 'gnus-server-visual
215 (defcustom gnus-server-closed-face 'gnus-server-closed-face
216 "Face name to use on CLOSED servers."
217 :group 'gnus-server-visual
220 (defcustom gnus-server-denied-face 'gnus-server-denied-face
221 "Face name to use on DENIED servers."
222 :group 'gnus-server-visual
225 (defcustom gnus-server-offline-face 'gnus-server-offline-face
226 "Face name to use on OFFLINE servers."
227 :group 'gnus-server-visual
230 (defvar gnus-server-font-lock-keywords
232 '("(\\(agent\\))" 1 gnus-server-agent-face)
233 '("(\\(opened\\))" 1 gnus-server-opened-face)
234 '("(\\(closed\\))" 1 gnus-server-closed-face)
235 '("(\\(offline\\))" 1 gnus-server-offline-face)
236 '("(\\(denied\\))" 1 gnus-server-denied-face)))
238 (defun gnus-server-mode ()
239 "Major mode for listing and editing servers.
241 All normal editing commands are switched off.
242 \\<gnus-server-mode-map>
243 For more in-depth information on this mode, read the manual
244 \(`\\[gnus-info-find-node]').
246 The following commands are available:
248 \\{gnus-server-mode-map}"
250 (when (gnus-visual-p 'server-menu 'menu)
251 (gnus-server-make-menu-bar))
252 (kill-all-local-variables)
253 (gnus-simplify-mode-line)
254 (setq major-mode 'gnus-server-mode)
255 (setq mode-name "Server")
256 (gnus-set-default-directory)
257 (setq mode-line-process nil)
258 (use-local-map gnus-server-mode-map)
259 (buffer-disable-undo)
260 (setq truncate-lines t)
261 (setq buffer-read-only t)
262 (if (featurep 'xemacs)
263 (put 'gnus-server-mode 'font-lock-defaults '(gnus-server-font-lock-keywords t))
264 (set (make-local-variable 'font-lock-defaults)
265 '(gnus-server-font-lock-keywords t)))
266 (gnus-run-hooks 'gnus-server-mode-hook))
268 (defun gnus-server-insert-server-line (gnus-tmp-name method)
269 (let* ((gnus-tmp-how (car method))
270 (gnus-tmp-where (nth 1 method))
271 (elem (assoc method gnus-opened-servers))
274 ((eq (nth 1 elem) 'denied) "(denied)")
275 ((eq (nth 1 elem) 'offline) "(offline)")
278 (if (or (gnus-server-opened method)
279 (eq (nth 1 elem) 'ok))
282 ((error) "(error)")))))
283 (gnus-tmp-agent (if (and gnus-agent
285 gnus-agent-covered-methods))
289 (gnus-add-text-properties
293 (eval gnus-server-line-format-spec))
294 (list 'gnus-server (intern gnus-tmp-name)))))
296 (defun gnus-enter-server-buffer ()
297 "Set up the server buffer."
298 (gnus-server-setup-buffer)
299 (gnus-configure-windows 'server)
300 (gnus-server-prepare))
302 (defun gnus-server-setup-buffer ()
303 "Initialize the server buffer."
304 (unless (get-buffer gnus-server-buffer)
306 (set-buffer (gnus-get-buffer-create gnus-server-buffer))
309 (gnus-carpal-setup-buffer 'server)))))
311 (defun gnus-server-prepare ()
312 (gnus-set-format 'server-mode)
313 (gnus-set-format 'server t)
314 (let ((alist gnus-server-alist)
315 (buffer-read-only nil)
316 (opened gnus-opened-servers)
319 (setq gnus-inserted-opened-servers nil)
320 ;; First we do the real list of servers.
322 (unless (member (cdar alist) done)
323 (push (cdar alist) done)
324 (cdr (setq server (pop alist)))
325 (when (and server (car server) (cdr server))
326 (gnus-server-insert-server-line (car server) (cdr server))))
327 (when (member (cdar alist) done)
329 ;; Then we insert the list of servers that have been opened in
332 (when (and (not (member (caar opened) done))
333 ;; Just ignore ephemeral servers.
334 (not (member (caar opened) gnus-ephemeral-servers)))
335 (push (caar opened) done)
336 (gnus-server-insert-server-line
337 (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened))))
339 (push (list op-ser (caar opened)) gnus-inserted-opened-servers))
340 (setq opened (cdr opened))))
341 (goto-char (point-min))
342 (gnus-server-position-point))
344 (defun gnus-server-server-name ()
345 (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server)))
346 (and server (symbol-name server))))
348 (defalias 'gnus-server-position-point 'gnus-goto-colon)
350 (defconst gnus-server-edit-buffer "*Gnus edit server*")
352 (defun gnus-server-update-server (server)
354 (set-buffer gnus-server-buffer)
355 (let* ((buffer-read-only nil)
356 (entry (assoc server gnus-server-alist))
357 (oentry (assoc (gnus-server-to-method server)
358 gnus-opened-servers)))
361 (concat "(gnus-server-set-info \"" server "\" '"
362 (prin1-to-string (cdr entry)) ")\n")))
363 (when (or entry oentry)
364 ;; Buffer may be narrowed.
367 (when (gnus-server-goto-server server)
370 (gnus-server-insert-server-line (car entry) (cdr entry))
371 (gnus-server-insert-server-line
372 (format "%s:%s" (caar oentry) (nth 1 (car oentry)))
374 (gnus-server-position-point))))))
376 (defun gnus-server-set-info (server info)