1 ;;; gnus-srvr.el --- virtual server support for Gnus
3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
4 ;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
28 (eval-when-compile (require 'cl))
36 (defcustom gnus-server-mode-hook nil
37 "Hook run in `gnus-server-mode' buffers."
41 (defcustom gnus-server-exit-hook nil
42 "Hook run when exiting the server buffer."
46 (defcustom gnus-server-line-format " {%(%h:%w%)} %s%a\n"
47 "Format of server lines.
48 It works along the same lines as a normal formatting string,
49 with some simple extensions.
51 The following specs are understood:
59 General format specifiers can also be used.
60 See Info node `(gnus)Formatting Variables'."
61 :link '(custom-manual "(gnus)Formatting Variables")
62 :group 'gnus-server-visual
65 (defcustom gnus-server-mode-line-format "Gnus: %%b"
66 "The format specification for the server mode line."
67 :group 'gnus-server-visual
70 (defcustom gnus-server-browse-in-group-buffer nil
71 "Whether server browsing should take place in the group buffer.
72 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 ["Compact" gnus-server-compact-server t]
118 ["Exit" gnus-server-exit t]))
121 gnus-server-connections-menu gnus-server-mode-map ""
123 ["Open" gnus-server-open-server t]
124 ["Close" gnus-server-close-server t]
125 ["Offline" gnus-server-offline-server t]
126 ["Deny" gnus-server-deny-server t]
128 ["Open All" gnus-server-open-all-servers t]
129 ["Close All" gnus-server-close-all-servers t]
130 ["Reset All" gnus-server-remove-denials t]))
132 (gnus-run-hooks 'gnus-server-menu-hook)))
134 (defvar gnus-server-mode-map nil)
135 (put 'gnus-server-mode 'mode-class 'special)
137 (unless gnus-server-mode-map
138 (setq gnus-server-mode-map (make-sparse-keymap))
139 (suppress-keymap gnus-server-mode-map)
141 (gnus-define-keys gnus-server-mode-map
142 " " gnus-server-read-server-in-server-buffer
143 "\r" gnus-server-read-server
144 gnus-mouse-2 gnus-server-pick-server
146 "l" gnus-server-list-servers
147 "k" gnus-server-kill-server
148 "y" gnus-server-yank-server
149 "c" gnus-server-copy-server
150 "a" gnus-server-add-server
151 "e" gnus-server-edit-server
152 "s" gnus-server-scan-server
154 "O" gnus-server-open-server
155 "\M-o" gnus-server-open-all-servers
156 "C" gnus-server-close-server
157 "\M-c" gnus-server-close-all-servers
158 "D" gnus-server-deny-server
159 "L" gnus-server-offline-server
160 "R" gnus-server-remove-denials
165 "g" gnus-server-regenerate-server
167 "z" gnus-server-compact-server
169 "\C-c\C-i" gnus-info-find-node
170 "\C-c\C-b" gnus-bug))
172 (defface gnus-server-agent
173 '((((class color) (background light)) (:foreground "PaleTurquoise" :bold t))
174 (((class color) (background dark)) (:foreground "PaleTurquoise" :bold t))
176 "Face used for displaying AGENTIZED servers"
177 :group 'gnus-server-visual)
178 ;; backward-compatibility alias
179 (put 'gnus-server-agent-face 'face-alias 'gnus-server-agent)
180 (put 'gnus-server-agent-face 'obsolete-face "22.1")
182 (defface gnus-server-opened
183 '((((class color) (background light)) (:foreground "Green3" :bold t))
184 (((class color) (background dark)) (:foreground "Green1" :bold t))
186 "Face used for displaying OPENED servers"
187 :group 'gnus-server-visual)
188 ;; backward-compatibility alias
189 (put 'gnus-server-opened-face 'face-alias 'gnus-server-opened)
190 (put 'gnus-server-opened-face 'obsolete-face "22.1")
192 (defface gnus-server-closed
193 '((((class color) (background light)) (:foreground "Steel Blue" :italic t))
194 (((class color) (background dark))
195 (:foreground "LightBlue" :italic t))
197 "Face used for displaying CLOSED servers"
198 :group 'gnus-server-visual)
199 ;; backward-compatibility alias
200 (put 'gnus-server-closed-face 'face-alias 'gnus-server-closed)
201 (put 'gnus-server-closed-face 'obsolete-face "22.1")
203 (defface gnus-server-denied
204 '((((class color) (background light)) (:foreground "Red" :bold t))
205 (((class color) (background dark)) (:foreground "Pink" :bold t))
206 (t (:inverse-video t :bold t)))
207 "Face used for displaying DENIED servers"
208 :group 'gnus-server-visual)
209 ;; backward-compatibility alias
210 (put 'gnus-server-denied-face 'face-alias 'gnus-server-denied)
211 (put 'gnus-server-denied-face 'obsolete-face "22.1")
213 (defface gnus-server-offline
214 '((((class color) (background light)) (:foreground "Orange" :bold t))
215 (((class color) (background dark)) (:foreground "Yellow" :bold t))
216 (t (:inverse-video t :bold t)))
217 "Face used for displaying OFFLINE servers"
218 :group 'gnus-server-visual)
219 ;; backward-compatibility alias
220 (put 'gnus-server-offline-face 'face-alias 'gnus-server-offline)
221 (put 'gnus-server-offline-face 'obsolete-face "22.1")
223 (defvar gnus-server-font-lock-keywords
224 '(("(\\(agent\\))" 1 'gnus-server-agent)
225 ("(\\(opened\\))" 1 'gnus-server-opened)
226 ("(\\(closed\\))" 1 'gnus-server-closed)
227 ("(\\(offline\\))" 1 'gnus-server-offline)
228 ("(\\(denied\\))" 1 'gnus-server-denied)))
230 (defun gnus-server-mode ()
231 "Major mode for listing and editing servers.
233 All normal editing commands are switched off.
234 \\<gnus-server-mode-map>
235 For more in-depth information on this mode, read the manual
236 \(`\\[gnus-info-find-node]').
238 The following commands are available:
240 \\{gnus-server-mode-map}"
242 (when (gnus-visual-p 'server-menu 'menu)
243 (gnus-server-make-menu-bar))
244 (kill-all-local-variables)
245 (gnus-simplify-mode-line)
246 (setq major-mode 'gnus-server-mode)
247 (setq mode-name "Server")
248 (gnus-set-default-directory)
249 (setq mode-line-process nil)
250 (use-local-map gnus-server-mode-map)
251 (buffer-disable-undo)
252 (setq truncate-lines t)
253 (setq buffer-read-only t)
254 (if (featurep 'xemacs)
255 (put 'gnus-server-mode 'font-lock-defaults '(gnus-server-font-lock-keywords t))
256 (set (make-local-variable 'font-lock-defaults)
257 '(gnus-server-font-lock-keywords t)))
258 (gnus-run-mode-hooks 'gnus-server-mode-hook))
260 (defun gnus-server-insert-server-line (gnus-tmp-name method)
261 (let* ((gnus-tmp-how (car method))
262 (gnus-tmp-where (nth 1 method))
263 (elem (assoc method gnus-opened-servers))
266 ((eq (nth 1 elem) 'denied) "(denied)")
267 ((eq (nth 1 elem) 'offline) "(offline)")
270 (if (or (gnus-server-opened method)
271 (eq (nth 1 elem) 'ok))
274 ((error) "(error)")))))
275 (gnus-tmp-agent (if (and gnus-agent
276 (gnus-agent-method-p method))
280 (gnus-add-text-properties
284 (eval gnus-server-line-format-spec))
285 (list 'gnus-server (intern gnus-tmp-name)
286 'gnus-named-server (intern (gnus-method-to-server method t))))))
288 (defun gnus-enter-server-buffer ()
289 "Set up the server buffer."
290 (gnus-server-setup-buffer)
291 (gnus-configure-windows 'server)
292 ;; Usually `gnus-configure-windows' will finish with the
293 ;; `gnus-server-buffer' selected as the current buffer, but not always (I
294 ;; bumped into it when starting from a dedicated *Group* frame, and
295 ;; gnus-configure-windows opened *Server* into its own dedicated frame).
296 (with-current-buffer (get-buffer gnus-server-buffer)
297 (gnus-server-prepare)))
299 (defun gnus-server-setup-buffer ()
300 "Initialize the server buffer."
301 (unless (get-buffer gnus-server-buffer)
302 (with-current-buffer (gnus-get-buffer-create gnus-server-buffer)
305 (gnus-carpal-setup-buffer 'server)))))
307 (defun gnus-server-prepare ()
308 (gnus-set-format 'server-mode)
309 (gnus-set-format 'server t)
310 (let ((alist gnus-server-alist)
311 (buffer-read-only nil)
314 (setq gnus-inserted-opened-servers nil)
315 ;; First we do the real list of servers.
317 (unless (member (cdar alist) done)
318 (push (cdar alist) done)
319 (setq server (pop alist))
320 (when (and server (car server) (cdr server))
321 (gnus-server-insert-server-line (car server) (cdr server))))
322 (when (member (cdar alist) done)
324 ;; Then we insert the list of servers that have been opened in
326 (dolist (open gnus-opened-servers)
327 (when (and (not (member (car open) done))
328 ;; Just ignore ephemeral servers.
329 (not (member (car open) gnus-ephemeral-servers)))
330 (push (car open) done)
331 (gnus-server-insert-server-line
332 (setq op-ser (format "%s:%s" (caar open) (nth 1 (car open))))
334 (push (list op-ser (car open)) gnus-inserted-opened-servers))))
335 (goto-char (point-min))
336 (gnus-server-position-point))
338 (defun gnus-server-server-name ()
339 (let ((server (get-text-property (point-at-bol) 'gnus-server)))
340 (and server (symbol-name server))))
342 (defun gnus-server-named-server ()
343 "Return a server name that matches one of the names returned by
344 `gnus-method-to-server'."
345 (let ((server (get-text-property (point-at-bol) 'gnus-named-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)
353 (with-current-buffer gnus-server-buffer
354 (let* ((buffer-read-only nil)
355 (entry (assoc server gnus-server-alist))
356 (oentry (assoc (gnus-server-to-method server)
357 gnus-opened-servers)))
360 (concat "(gnus-server-set-info \"" server "\" '"
361 (gnus-prin1-to-string (cdr entry)) ")\n")))
362 (when (or entry oentry)
363 ;; Buffer may be narrowed.
366 (when (gnus-server-goto-server server)
369 (gnus-server-insert-server-line (car entry) (cdr entry))
370 (gnus-server-insert-server-line
371 (format "%s:%s" (caar oentry) (nth 1 (car oentry)))
373 (gnus-server-position-point))))))
375 (defun gnus-server-set-info (server info)
376 ;; Enter a select method into the virtual server alist.
377 (when (and server info)
379 (concat "(gnus-server-set-info \"" server "\" '"
380 (gnus-prin1-to-string info) ")"))
381 (let* ((server (nth 1 info))
382 (entry (assoc server gnus-server-alist))
383 (cached (assoc server gnus-server-method-cache)))
385 (setq gnus-server-method-cache
386 (delq cached gnus-server-method-cache)))
389 ;; Remove the server from `gnus-opened-servers' since
390 ;; it has never been opened with the new `info' yet.
391 (gnus-opened-servers-remove (cdr entry))
392 ;; Don't make a new Lisp object.
393 (setcar (cdr entry) (car info))
394 (setcdr (cdr entry) (cdr info)))
395 (setq gnus-server-alist
396 (nconc gnus-server-alist (list (cons server info))))))))
398 ;;; Interactive server functions.
400 (defun gnus-server-kill-server (server)
401 "Kill the server on the current line."
402 (interactive (list (gnus-server-server-name)))
403 (unless (gnus-server-goto-server server)
404 (if server (error "No such server: %s" server)
405 (error "No server on the current line")))
406 (unless (assoc server gnus-server-alist)
407 (error "Read-only server %s" server))
409 (let ((buffer-read-only nil))
411 (push (assoc server gnus-server-alist) gnus-server-killed-servers)
412 (setq gnus-server-alist (delq (car gnus-server-killed-servers)
414 (let ((groups (gnus-groups-from-server server)))
417 (format "Kill all %s groups from this server? "
419 (dolist (group groups)
420 (setq gnus-newsrc-alist
421 (delq (assoc group gnus-newsrc-alist)
423 (when gnus-group-change-level-function
424 (funcall gnus-group-change-level-function
425 group gnus-level-killed 3)))))
426 (gnus-server-position-point))
428 (defun gnus-server-yank-server ()
429 "Yank the previously killed server."
431 (unless gnus-server-killed-servers
432 (error "No killed servers to be yanked"))
433 (let ((alist gnus-server-alist)
434 (server (gnus-server-server-name))
435 (killed (car gnus-server-killed-servers)))
437 (setq gnus-server-alist (nconc gnus-server-alist (list killed)))
438 (if (string= server (caar gnus-server-alist))
439 (push killed gnus-server-alist)
440 (while (and (cdr alist)
441 (not (string= server (caadr alist))))
442 (setq alist (cdr alist)))
444 (setcdr alist (cons killed (cdr alist)))
445 (setq gnus-server-alist (list killed)))))
446 (gnus-server-update-server (car killed))
447 (setq gnus-server-killed-servers (cdr gnus-server-killed-servers))
448 (gnus-server-position-point)))
450 (defun gnus-server-exit ()
451 "Return to the group buffer."
453 (gnus-run-hooks 'gnus-server-exit-hook)
454 (gnus-kill-buffer (current-buffer))
455 (gnus-configure-windows 'group t))
457 (defun gnus-server-list-servers ()
458 "List all available servers."