HCoop / bpt / emacs.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Switch to recommended form of GPLv3 permissions notice.
[bpt/emacs.git] / lisp / gnus / gnus-srvr.el
CommitLineData
eec82323 1;;; gnus-srvr.el --- virtual server support for Gnus
e84b4b86 2
cfcd5c91 3;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
e3fe4da0 4;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
eec82323 5
6748645f 6;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
eec82323
LMI		 7;; Keywords: news
8
9;; This file is part of GNU Emacs.
10
5e809f55 11;; GNU Emacs is free software: you can redistribute it and/or modify
eec82323 12;; it under the terms of the GNU General Public License as published by
5e809f55
GM		 13;; the Free Software Foundation, either version 3 of the License, or
14;; (at your option) any later version.
eec82323
LMI		 15
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.
20
21;; You should have received a copy of the GNU General Public License
5e809f55 22;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
eec82323
LMI		 23
24;;; Commentary:
25
26;;; Code:
27
5ab7173c
RS		 28(eval-when-compile (require 'cl))
29
eec82323
LMI		 30(require 'gnus)
31(require 'gnus-spec)
32(require 'gnus-group)
33(require 'gnus-int)
34(require 'gnus-range)
35
23f87bed
MB		 36(defcustom gnus-server-mode-hook nil
37 "Hook run in `gnus-server-mode' buffers."
38 :group 'gnus-server
39 :type 'hook)
eec82323 40
23f87bed
MB		 41(defcustom gnus-server-exit-hook nil
42 "Hook run when exiting the server buffer."
43 :group 'gnus-server
44 :type 'hook)
45
46(defcustom gnus-server-line-format " {%(%h:%w%)} %s%a\n"
eec82323
LMI		 47 "Format of server lines.
48It works along the same lines as a normal formatting string,
6748645f
LMI		 49with some simple extensions.
50
51The following specs are understood:
52
01c52d31 53%h back end
6748645f
LMI		 54%n name
55%w address
23f87bed
MB		 56%s status
57%a agent covered
58
59General format specifiers can also be used.
60See Info node `(gnus)Formatting Variables'."
61 :link '(custom-manual "(gnus)Formatting Variables")
62 :group 'gnus-server-visual
63 :type 'string)
64
65(defcustom gnus-server-mode-line-format "Gnus: %%b"
66 "The format specification for the server mode line."
67 :group 'gnus-server-visual
68 :type 'string)
69
70(defcustom gnus-server-browse-in-group-buffer nil
71 "Whether server browsing should take place in the group buffer.
72If nil, a faster, but more primitive, buffer is used instead."
bf247b6e 73 :version "22.1"
23f87bed
MB		 74 :group 'gnus-server-visual
75 :type 'boolean)
eec82323
LMI		 76
77;;; Internal variables.
78
79(defvar gnus-inserted-opened-servers nil)
80
81(defvar gnus-server-line-format-alist
6748645f
LMI		 82 `((?h gnus-tmp-how ?s)
83 (?n gnus-tmp-name ?s)
84 (?w gnus-tmp-where ?s)
23f87bed
MB		 85 (?s gnus-tmp-status ?s)
86 (?a gnus-tmp-agent ?s)))
eec82323
LMI		 87
88(defvar gnus-server-mode-line-format-alist
6748645f
LMI		 89 `((?S gnus-tmp-news-server ?s)
90 (?M gnus-tmp-news-method ?s)
91 (?u gnus-tmp-user-defined ?s)))
eec82323
LMI		 92
93(defvar gnus-server-line-format-spec nil)
94(defvar gnus-server-mode-line-format-spec nil)
95(defvar gnus-server-killed-servers nil)
96
97(defvar gnus-server-mode-map)
98
99(defvar gnus-server-menu-hook nil
100 "*Hook run after the creation of the server mode menu.")
101
102(defun gnus-server-make-menu-bar ()
103 (gnus-turn-off-edit-menu 'server)
104 (unless (boundp 'gnus-server-server-menu)
105 (easy-menu-define
106 gnus-server-server-menu gnus-server-mode-map ""
107 '("Server"
23f87bed 108 ["Add..." gnus-server-add-server t]
eec82323
LMI		 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]
01c52d31 117 ["Compact" gnus-server-compact-server t]
eec82323
LMI		 118 ["Exit" gnus-server-exit t]))
119
120 (easy-menu-define
121 gnus-server-connections-menu gnus-server-mode-map ""
122 '("Connections"
123 ["Open" gnus-server-open-server t]
124 ["Close" gnus-server-close-server t]
23f87bed 125 ["Offline" gnus-server-offline-server t]
eec82323
LMI		 126 ["Deny" gnus-server-deny-server t]
127 "---"
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]))
131
6748645f 132 (gnus-run-hooks 'gnus-server-menu-hook)))
eec82323
LMI		 133
134(defvar gnus-server-mode-map nil)
135(put 'gnus-server-mode 'mode-class 'special)
136
137(unless gnus-server-mode-map
138 (setq gnus-server-mode-map (make-sparse-keymap))
139 (suppress-keymap gnus-server-mode-map)
140
6748645f 141 (gnus-define-keys gnus-server-mode-map
23f87bed 142 " " gnus-server-read-server-in-server-buffer
6748645f
LMI		 143 "\r" gnus-server-read-server
144 gnus-mouse-2 gnus-server-pick-server
145 "q" gnus-server-exit
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
153
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
23f87bed 159 "L" gnus-server-offline-server
6748645f
LMI		 160 "R" gnus-server-remove-denials
161
16409b0b
GM		 162 "n" next-line
163 "p" previous-line
a1506d29 164
6748645f 165 "g" gnus-server-regenerate-server
eec82323 166
01c52d31
MB		 167 "z" gnus-server-compact-server
168
eec82323
LMI		 169 "\C-c\C-i" gnus-info-find-node
170 "\C-c\C-b" gnus-bug))
171
0f49874b 172(defface gnus-server-agent
23f87bed
MB		 173 '((((class color) (background light)) (:foreground "PaleTurquoise" :bold t))
174 (((class color) (background dark)) (:foreground "PaleTurquoise" :bold t))
175 (t (:bold t)))
176 "Face used for displaying AGENTIZED servers"
177 :group 'gnus-server-visual)
0f49874b
MB		 178;; backward-compatibility alias
179(put 'gnus-server-agent-face 'face-alias 'gnus-server-agent)
23f87bed 180
0f49874b 181(defface gnus-server-opened
23f87bed
MB		 182 '((((class color) (background light)) (:foreground "Green3" :bold t))
183 (((class color) (background dark)) (:foreground "Green1" :bold t))
184 (t (:bold t)))
185 "Face used for displaying OPENED servers"
186 :group 'gnus-server-visual)
0f49874b
MB		 187;; backward-compatibility alias
188(put 'gnus-server-opened-face 'face-alias 'gnus-server-opened)
23f87bed 189
0f49874b 190(defface gnus-server-closed
23f87bed
MB		 191 '((((class color) (background light)) (:foreground "Steel Blue" :italic t))
192 (((class color) (background dark))
01c52d31 193 (:foreground "LightBlue" :italic t))
23f87bed
MB		 194 (t (:italic t)))
195 "Face used for displaying CLOSED servers"
196 :group 'gnus-server-visual)
0f49874b
MB		 197;; backward-compatibility alias
198(put 'gnus-server-closed-face 'face-alias 'gnus-server-closed)
23f87bed 199
0f49874b 200(defface gnus-server-denied
23f87bed
MB		 201 '((((class color) (background light)) (:foreground "Red" :bold t))
202 (((class color) (background dark)) (:foreground "Pink" :bold t))
203 (t (:inverse-video t :bold t)))
204 "Face used for displaying DENIED servers"
205 :group 'gnus-server-visual)
0f49874b
MB		 206;; backward-compatibility alias
207(put 'gnus-server-denied-face 'face-alias 'gnus-server-denied)
23f87bed 208
0f49874b 209(defface gnus-server-offline
23f87bed
MB		 210 '((((class color) (background light)) (:foreground "Orange" :bold t))
211 (((class color) (background dark)) (:foreground "Yellow" :bold t))
212 (t (:inverse-video t :bold t)))
213 "Face used for displaying OFFLINE servers"
214 :group 'gnus-server-visual)
0f49874b
MB		 215;; backward-compatibility alias
216(put 'gnus-server-offline-face 'face-alias 'gnus-server-offline)
23f87bed 217
23f87bed 218(defvar gnus-server-font-lock-keywords
f931ce84
MB		 219 '(("(\\(agent\\))" 1 'gnus-server-agent)
220 ("(\\(opened\\))" 1 'gnus-server-opened)
221 ("(\\(closed\\))" 1 'gnus-server-closed)
222 ("(\\(offline\\))" 1 'gnus-server-offline)
223 ("(\\(denied\\))" 1 'gnus-server-denied)))
23f87bed 224
eec82323
LMI		 225(defun gnus-server-mode ()
226 "Major mode for listing and editing servers.
227
228All normal editing commands are switched off.
229\\<gnus-server-mode-map>
230For more in-depth information on this mode, read the manual
acc15099 231\(`\\[gnus-info-find-node]').
eec82323
LMI		 232
233The following commands are available:
234
235\\{gnus-server-mode-map}"
236 (interactive)
237 (when (gnus-visual-p 'server-menu 'menu)
238 (gnus-server-make-menu-bar))
239 (kill-all-local-variables)
240 (gnus-simplify-mode-line)
241 (setq major-mode 'gnus-server-mode)
242 (setq mode-name "Server")
243 (gnus-set-default-directory)
244 (setq mode-line-process nil)
245 (use-local-map gnus-server-mode-map)
16409b0b 246 (buffer-disable-undo)
eec82323
LMI		 247 (setq truncate-lines t)
248 (setq buffer-read-only t)
23f87bed
MB		 249 (if (featurep 'xemacs)
250 (put 'gnus-server-mode 'font-lock-defaults '(gnus-server-font-lock-keywords t))
251 (set (make-local-variable 'font-lock-defaults)
252 '(gnus-server-font-lock-keywords t)))
cfcd5c91 253 (gnus-run-mode-hooks 'gnus-server-mode-hook))
eec82323 254
6748645f
LMI		 255(defun gnus-server-insert-server-line (gnus-tmp-name method)
256 (let* ((gnus-tmp-how (car method))
257 (gnus-tmp-where (nth 1 method))
eec82323 258 (elem (assoc method gnus-opened-servers))
13efce40 259 (gnus-tmp-status
23f87bed
MB		 260 (cond
261 ((eq (nth 1 elem) 'denied) "(denied)")
262 ((eq (nth 1 elem) 'offline) "(offline)")
263 (t
13efce40
MB		 264 (condition-case nil
265 (if (or (gnus-server-opened method)
266 (eq (nth 1 elem) 'ok))
267 "(opened)"
268 "(closed)")
269 ((error) "(error)")))))
23f87bed
MB		 270 (gnus-tmp-agent (if (and gnus-agent
271 (gnus-agent-method-p method))
272 " (agent)"
273 "")))
eec82323
LMI		 274 (beginning-of-line)
275 (gnus-add-text-properties
276 (point)
277 (prog1 (1+ (point))
278 ;; Insert the text.
279 (eval gnus-server-line-format-spec))
23f87bed 280 (list 'gnus-server (intern gnus-tmp-name)
b890d447 281 'gnus-named-server (intern (gnus-method-to-server method t))))))
eec82323
LMI		 282
283(defun gnus-enter-server-buffer ()
284 "Set up the server buffer."
285 (gnus-server-setup-buffer)
286 (gnus-configure-windows 'server)
287 (gnus-server-prepare))
288
289(defun gnus-server-setup-buffer ()
290 "Initialize the server buffer."
291 (unless (get-buffer gnus-server-buffer)
292 (save-excursion
6748645f 293 (set-buffer (gnus-get-buffer-create gnus-server-buffer))
eec82323
LMI		 294 (gnus-server-mode)
295 (when gnus-carpal
296 (gnus-carpal-setup-buffer 'server)))))
297
298(defun gnus-server-prepare ()
6748645f
LMI		 299 (gnus-set-format 'server-mode)
300 (gnus-set-format 'server t)
eec82323
LMI		 301 (let ((alist gnus-server-alist)
302 (buffer-read-only nil)
eec82323
LMI		 303 done server op-ser)
304 (erase-buffer)
305 (setq gnus-inserted-opened-servers nil)
306 ;; First we do the real list of servers.
307 (while alist
308 (unless (member (cdar alist) done)
309 (push (cdar alist) done)
df9a602c 310 (setq server (pop alist))
eec82323
LMI		 311 (when (and server (car server) (cdr server))
312 (gnus-server-insert-server-line (car server) (cdr server))))
313 (when (member (cdar alist) done)
314 (pop alist)))
315 ;; Then we insert the list of servers that have been opened in
316 ;; this session.
01c52d31
MB		 317 (dolist (open gnus-opened-servers)
318 (when (and (not (member (car open) done))
6748645f 319 ;; Just ignore ephemeral servers.
01c52d31
MB		 320 (not (member (car open) gnus-ephemeral-servers)))
321 (push (car open) done)
eec82323 322 (gnus-server-insert-server-line
01c52d31
MB		 323 (setq op-ser (format "%s:%s" (caar open) (nth 1 (car open))))
324 (car open))
325 (push (list op-ser (car open)) gnus-inserted-opened-servers))))
eec82323
LMI		 326 (goto-char (point-min))
327 (gnus-server-position-point))
328
329(defun gnus-server-server-name ()
01c52d31 330 (let ((server (get-text-property (point-at-bol) 'gnus-server)))
eec82323
LMI		 331 (and server (symbol-name server))))
332
23f87bed 333(defun gnus-server-named-server ()
01c52d31
MB		 334 "Return a server name that matches one of the names returned by
335`gnus-method-to-server'."
336 (let ((server (get-text-property (point-at-bol) 'gnus-named-server)))
23f87bed
MB		 337 (and server (symbol-name server))))
338
eec82323
LMI		 339(defalias 'gnus-server-position-point 'gnus-goto-colon)
340
341(defconst gnus-server-edit-buffer "*Gnus edit server*")
342
343(defun gnus-server-update-server (server)
344 (save-excursion
345 (set-buffer gnus-server-buffer)
346 (let* ((buffer-read-only nil)
347 (entry (assoc server gnus-server-alist))
348 (oentry (assoc (gnus-server-to-method server)
349 gnus-opened-servers)))
350 (when entry
351 (gnus-dribble-enter
352 (concat "(gnus-server-set-info \"" server "\" '"
23f87bed 353 (gnus-prin1-to-string (cdr entry)) ")\n")))
eec82323
LMI		 354 (when (or entry oentry)
355 ;; Buffer may be narrowed.
356 (save-restriction
357 (widen)
358 (when (gnus-server-goto-server server)
359 (gnus-delete-line))
360 (if entry
361 (gnus-server-insert-server-line (car entry) (cdr entry))
362 (gnus-server-insert-server-line
363 (format "%s:%s" (caar oentry) (nth 1 (car oentry)))
364 (car oentry)))
365 (gnus-server-position-point))))))
366
367(defun gnus-server-set-info (server info)
368 ;; Enter a select method into the virtual server alist.
369 (when (and server info)
370 (gnus-dribble-enter
371 (concat "(gnus-server-set-info \"" server "\" '"
23f87bed 372 (gnus-prin1-to-string info) ")"))
eec82323 373 (let* ((server (nth 1 info))
23f87bed
MB		 374 (entry (assoc server gnus-server-alist))
375 (cached (assoc server gnus-server-method-cache)))
376 (if cached
377 (setq gnus-server-method-cache
378 (delq cached gnus-server-method-cache)))
01c52d31
MB		 379 (if entry
380 (progn
381 ;; Remove the server from `gnus-opened-servers' since
382 ;; it has never been opened with the new `info' yet.
383 (gnus-opened-servers-remove (cdr entry))
384 ;; Don't make a new Lisp object.
385 (setcar (cdr entry) (car info))
386 (setcdr (cdr entry) (cdr info)))
eec82323
LMI		 387 (setq gnus-server-alist
388 (nconc gnus-server-alist (list (cons server info))))))))
389
390;;; Interactive server functions.
391
392(defun gnus-server-kill-server (server)
393 "Kill the server on the current line."
394 (interactive (list (gnus-server-server-name)))
395 (unless (gnus-server-goto-server server)
396 (if server (error "No such server: %s" server)
397 (error "No server on the current line")))
398 (unless (assoc server gnus-server-alist)
399 (error "Read-only server %s" server))
6748645f 400 (gnus-dribble-touch)
eec82323
LMI		 401 (let ((buffer-read-only nil))
402 (gnus-delete-line))
403 (push (assoc server gnus-server-alist) gnus-server-killed-servers)
404 (setq gnus-server-alist (delq (car gnus-server-killed-servers)
405 gnus-server-alist))
16409b0b
GM		 406 (let ((groups (gnus-groups-from-server server)))
407 (when (and groups
408 (gnus-yes-or-no-p
409 (format "Kill all %s groups from this server? "
410 (length groups))))
411 (dolist (group groups)
412 (setq gnus-newsrc-alist
413 (delq (assoc group gnus-newsrc-alist)
414 gnus-newsrc-alist))
415 (when gnus-group-change-level-function
416 (funcall gnus-group-change-level-function
417 group gnus-level-killed 3)))))
eec82323
LMI		 418 (gnus-server-position-point))
419
420(defun gnus-server-yank-server ()
421 "Yank the previously killed server."
422 (interactive)
423 (unless gnus-server-killed-servers
424 (error "No killed servers to be yanked"))
425 (let ((alist gnus-server-alist)
426 (server (gnus-server-server-name))
427 (killed (car gnus-server-killed-servers)))
428 (if (not server)
429 (setq gnus-server-alist (nconc gnus-server-alist (list killed)))
430 (if (string= server (caar gnus-server-alist))
431 (push killed gnus-server-alist)
432 (while (and (cdr alist)
433 (not (string= server (caadr alist))))
434 (setq alist (cdr alist)))
435 (if alist
436 (setcdr alist (cons killed (cdr alist)))
23f87bed 437 (setq gnus-server-alist (list killed)))))
eec82323
LMI		 438 (gnus-server-update-server (car killed))
439 (setq gnus-server-killed-servers (cdr gnus-server-killed-servers))
440 (gnus-server-position-point)))
441
442(defun gnus-server-exit ()
443 "Return to the group buffer."
444 (interactive)
6748645f 445 (gnus-run-hooks 'gnus-server-exit-hook)
23f87bed 446 (gnus-kill-buffer (current-buffer))
eec82323
LMI		 447 (gnus-configure-windows 'group t))
448
449(defun gnus-server-list-servers ()
450 "List all available servers."
451 (interactive)
452 (let ((cur (gnus-server-server-name)))
453 (gnus-server-prepare)
454 (if cur (gnus-server-goto-server cur)
455 (goto-char (point-max))
456 (forward-line -1))
457 (gnus-server-position-point)))
458
459(defun gnus-server-set-status (method status)
460 "Make METHOD have STATUS."
461 (let ((entry (assoc method gnus-opened-servers)))
462 (if entry
463 (setcar (cdr entry) status)
464 (push (list method status) gnus-opened-servers))))
465
466(defun gnus-opened-servers-remove (method)
467 "Remove METHOD from the list of opened servers."
468 (setq gnus-opened-servers (delq (assoc method gnus-opened-servers)
469 gnus-opened-servers)))
470
471(defun gnus-server-open-server (server)
472 "Force an open of SERVER."
473 (interactive (list (gnus-server-server-name)))
474 (let ((method (gnus-server-to-method server)))
475 (unless method
476 (error "No such server: %s" server))
477 (gnus-server-set-status method 'ok)
478 (prog1
479 (or (gnus-open-server method)
480 (progn (message "Couldn't open %s" server) nil))
481 (gnus-server-update-server server)
482 (gnus-server-position-point))))
483
484(defun gnus-server-open-all-servers ()
485 "Open all servers."
486 (interactive)
01c52d31
MB		 487 (dolist (server gnus-inserted-opened-servers)
488 (gnus-server-open-server (car server))))
eec82323
LMI		 489
490(defun gnus-server-close-server (server)
491 "Close SERVER."
492 (interactive (list (gnus-server-server-name)))
493 (let ((method (gnus-server-to-method server)))
494 (unless method
495 (error "No such server: %s" server))
496 (gnus-server-set-status method 'closed)
497 (prog1
498 (gnus-close-server method)
499 (gnus-server-update-server server)
500 (gnus-server-position-point))))
501
23f87bed
MB		 502(defun gnus-server-offline-server (server)
503 "Set SERVER to offline."
504 (interactive (list (gnus-server-server-name)))
505 (let ((method (gnus-server-to-method server)))
506 (unless method
507 (error "No such server: %s" server))
508 (prog1
509 (gnus-close-server method)
510 (gnus-server-set-status method 'offline)
511 (gnus-server-update-server server)
512 (gnus-server-position-point))))
513
eec82323
LMI		 514(defun gnus-server-close-all-servers ()
515 "Close all servers."
516 (interactive)
23f87bed 517 (dolist (server gnus-inserted-opened-servers)
01c52d31
MB		 518 (gnus-server-close-server (car server)))
519 (dolist (server gnus-server-alist)
23f87bed 520 (gnus-server-close-server (car server))))
eec82323
LMI		 521
522(defun gnus-server-deny-server (server)
523 "Make sure SERVER will never be attempted opened."
524 (interactive (list (gnus-server-server-name)))
525 (let ((method (gnus-server-to-method server)))
526 (unless method
527 (error "No such server: %s" server))
528 (gnus-server-set-status method 'denied))
529 (gnus-server-update-server server)
530 (gnus-server-position-point)
531 t)
532
533(defun gnus-server-remove-denials ()
534 "Make all denied servers into closed servers."
535 (interactive)
23f87bed
MB		 536 (dolist (server gnus-opened-servers)
537 (when (eq (nth 1 server) 'denied)
538 (setcar (nthcdr 1 server) 'closed)))
eec82323
LMI		 539 (gnus-server-list-servers))
540
541(defun gnus-server-copy-server (from to)
542 (interactive
543 (list
544 (or (gnus-server-server-name)
545 (error "No server on the current line"))
546 (read-string "Copy to: ")))
547 (unless from
548 (error "No server on current line"))
549 (unless (and to (not (string= to "")))
550 (error "No name to copy to"))
551 (when (assoc to gnus-server-alist)
552 (error "%s already exists" to))
553 (unless (gnus-server-to-method from)
554 (error "%s: no such server" from))
555 (let ((to-entry (cons from (gnus-copy-sequence
556 (gnus-server-to-method from)))))
557 (setcar to-entry to)
558 (setcar (nthcdr 2 to-entry) to)
559 (push to-entry gnus-server-killed-servers)
560 (gnus-server-yank-server)))
561
562(defun gnus-server-add-server (how where)
563 (interactive
564 (list (intern (completing-read "Server method: "
565 gnus-valid-select-methods nil t))
566 (read-string "Server name: ")))
567 (when (assq where gnus-server-alist)
568 (error "Server with that name already defined"))
569 (push (list where how where) gnus-server-killed-servers)
570 (gnus-server-yank-server))
571
572(defun gnus-server-goto-server (server)
573 "Jump to a server line."
574 (interactive
575 (list (completing-read "Goto server: " gnus-server-alist nil t)))
576 (let ((to (text-property-any (point-min) (point-max)
577 'gnus-server (intern server))))
578 (when to
579 (goto-char to)
580 (gnus-server-position-point))))
581
582(defun gnus-server-edit-server (server)
583 "Edit the server on the current line."
584 (interactive (list (gnus-server-server-name)))
585 (unless server
586 (error "No server on current line"))
587 (unless (assoc server gnus-server-alist)
588 (error "This server can't be edited"))
589 (let ((info (cdr (assoc server gnus-server-alist))))
590 (gnus-close-server info)
591 (gnus-edit-form
592 info "Editing the server."
593 `(lambda (form)
594 (gnus-server-set-info ,server form)
595 (gnus-server-list-servers)
01c52d31
MB		 596 (gnus-server-position-point))
597 'edit-server)))
eec82323
LMI		 598
599(defun gnus-server-scan-server (server)
600 "Request a scan from the current server."
601 (interactive (list (gnus-server-server-name)))
6748645f
LMI		 602 (let ((method (gnus-server-to-method server)))
603 (if (not (gnus-get-function method 'request-scan))
604 (error "Server %s can't scan" (car method))
605 (gnus-message 3 "Scanning %s..." server)
606 (gnus-request-scan nil method)
607 (gnus-message 3 "Scanning %s...done" server))))
eec82323 608
23f87bed
MB		 609(defun gnus-server-read-server-in-server-buffer (server)
610 "Browse a server in server buffer."
611 (interactive (list (gnus-server-server-name)))
612 (let (gnus-server-browse-in-group-buffer)
613 (gnus-server-read-server server)))
614
eec82323
LMI		 615(defun gnus-server-read-server (server)
616 "Browse a server."
617 (interactive (list (gnus-server-server-name)))
618 (let ((buf (current-buffer)))
619 (prog1
6748645f 620 (gnus-browse-foreign-server server buf)
eec82323
LMI		 621 (save-excursion
622 (set-buffer buf)
623 (gnus-server-update-server (gnus-server-server-name))
624 (gnus-server-position-point)))))
625
626(defun gnus-server-pick-server (e)
627 (interactive "e")
628 (mouse-set-point e)
629 (gnus-server-read-server (gnus-server-server-name)))
630
631\f
632;;;
633;;; Browse Server Mode
634;;;
635
636(defvar gnus-browse-menu-hook nil
637 "*Hook run after the creation of the browse mode menu.")
638
639(defvar gnus-browse-mode-hook nil)
640(defvar gnus-browse-mode-map nil)
641(put 'gnus-browse-mode 'mode-class 'special)
642
643(unless gnus-browse-mode-map
644 (setq gnus-browse-mode-map (make-keymap))
645 (suppress-keymap gnus-browse-mode-map)
646
647 (gnus-define-keys
16409b0b
GM		 648 gnus-browse-mode-map
649 " " gnus-browse-read-group
650 "=" gnus-browse-select-group
651 "n" gnus-browse-next-group
652 "p" gnus-browse-prev-group
653 "\177" gnus-browse-prev-group
654 [delete] gnus-browse-prev-group
655 "N" gnus-browse-next-group
656 "P" gnus-browse-prev-group
657 "\M-n" gnus-browse-next-group
658 "\M-p" gnus-browse-prev-group
659 "\r" gnus-browse-select-group
660 "u" gnus-browse-unsubscribe-current-group
661 "l" gnus-browse-exit
662 "L" gnus-browse-exit
663 "q" gnus-browse-exit
664 "Q" gnus-browse-exit
23f87bed 665 "d" gnus-browse-describe-group
16409b0b
GM		 666 "\C-c\C-c" gnus-browse-exit
667 "?" gnus-browse-describe-briefly
668
669 "\C-c\C-i" gnus-info-find-node
670 "\C-c\C-b" gnus-bug))
eec82323
LMI		 671
672(defun gnus-browse-make-menu-bar ()
673 (gnus-turn-off-edit-menu 'browse)
674 (unless (boundp 'gnus-browse-menu)
675 (easy-menu-define
676 gnus-browse-menu gnus-browse-mode-map ""
677 '("Browse"
678 ["Subscribe" gnus-browse-unsubscribe-current-group t]
679 ["Read" gnus-browse-read-group t]
6748645f 680 ["Select" gnus-browse-select-group t]
23f87bed 681 ["Describe" gnus-browse-describe-group t]
eec82323 682 ["Next" gnus-browse-next-group t]
158f4aea 683 ["Prev" gnus-browse-prev-group t]
eec82323 684 ["Exit" gnus-browse-exit t]))
6748645f 685 (gnus-run-hooks 'gnus-browse-menu-hook)))
eec82323
LMI		 686
687(defvar gnus-browse-current-method nil)
688(defvar gnus-browse-return-buffer nil)
689
690(defvar gnus-browse-buffer "*Gnus Browse Server*")
691
6748645f
LMI		 692(defun gnus-browse-foreign-server (server &optional return-buffer)
693 "Browse the server SERVER."
16409b0b 694 (setq gnus-browse-current-method (gnus-server-to-method server))
eec82323 695 (setq gnus-browse-return-buffer return-buffer)
16409b0b 696 (let* ((method gnus-browse-current-method)
23f87bed 697 (orig-select-method gnus-select-method)
6748645f
LMI		 698 (gnus-select-method method)
699 groups group)
eec82323
LMI		 700 (gnus-message 5 "Connecting to %s..." (nth 1 method))
701 (cond
702 ((not (gnus-check-server method))
703 (gnus-message
a8151ef7
LMI		 704 1 "Unable to contact server %s: %s" (nth 1 method)
705 (gnus-status-message method))
eec82323
LMI		 706 nil)
707 ((not
708 (prog2
709 (gnus-message 6 "Reading active file...")
710 (gnus-request-list method)
711 (gnus-message 6 "Reading active file...done")))
712 (gnus-message
713 1 "Couldn't request list: %s" (gnus-status-message method))
714 nil)
715 (t
23f87bed 716 (with-current-buffer nntp-server-buffer
eec82323
LMI		 717 (let ((cur (current-buffer)))
718 (goto-char (point-min))
719 (unless (string= gnus-ignored-newsgroups "")
720 (delete-matching-lines gnus-ignored-newsgroups))
23f87bed
MB		 721 ;; We treat NNTP as a special case to avoid problems with
722 ;; garbage group names like `"foo' that appear in some badly
723 ;; managed active files. -jh.
724 (if (eq (car method) 'nntp)
725 (while (not (eobp))
726 (ignore-errors
bf247b6e 727 (push (cons
01c52d31
MB		 728 (mm-string-as-unibyte
729 (buffer-substring
730 (point)
731 (progn
732 (skip-chars-forward "^ \t")
733 (point))))
23f87bed
MB		 734 (let ((last (read cur)))
735 (cons (read cur) last)))
736 groups))
737 (forward-line))
738 (while (not (eobp))
739 (ignore-errors
740 (push (cons
01c52d31
MB		 741 (mm-string-as-unibyte
742 (if (eq (char-after) ?\")
743 (read cur)
744 (let ((p (point)) (name ""))
745 (skip-chars-forward "^ \t\\\\")
746 (setq name (buffer-substring p (point)))
747 (while (eq (char-after) ?\\)
748 (setq p (1+ (point)))
749 (forward-char 2)
750 (skip-chars-forward "^ \t\\\\")
751 (setq name (concat name (buffer-substring
752 p (point)))))
753 name)))
23f87bed
MB		 754 (let ((last (read cur)))
755 (cons (read cur) last)))
756 groups))
757 (forward-line)))))
eec82323
LMI		 758 (setq groups (sort groups
759 (lambda (l1 l2)
760 (string< (car l1) (car l2)))))
23f87bed
MB		 761 (if gnus-server-browse-in-group-buffer
762 (let* ((gnus-select-method orig-select-method)
763 (gnus-group-listed-groups
764 (mapcar (lambda (group)
765 (let ((name
766 (gnus-group-prefixed-name
767 (car group) method)))
768 (gnus-set-active name (cdr group))
769 name))
770 groups)))
771 (gnus-configure-windows 'group)
772 (funcall gnus-group-prepare-function
773 gnus-level-killed 'ignore 1 'ignore))
774 (gnus-get-buffer-create gnus-browse-buffer)
775 (when gnus-carpal
776 (gnus-carpal-setup-buffer 'browse))
777 (gnus-configure-windows 'browse)
778 (buffer-disable-undo)
779 (let ((buffer-read-only nil))
780 (erase-buffer))
781 (gnus-browse-mode)
782 (setq mode-line-buffer-identification
783 (list
784 (format
785 "Gnus: %%b {%s:%s}" (car method) (cadr method))))
786 (let ((buffer-read-only nil)
787 name
788 (prefix (let ((gnus-select-method orig-select-method))
789 (gnus-group-prefixed-name "" method))))
790 (while (setq group (pop groups))
791 (gnus-add-text-properties
792 (point)
793 (prog1 (1+ (point))
794 (insert
795 (format "%c%7d: %s\n"
01c52d31
MB		 796 (let ((level
797 (if (string= prefix "")
798 (gnus-group-level (setq name (car group)))
799 (gnus-group-level
800 (concat prefix (setq name (car group)))))))
801 (cond
802 ((<= level gnus-level-subscribed) ? )
803 ((<= level gnus-level-unsubscribed) ?U)
804 ((= level gnus-level-zombie) ?Z)
805 (t ?K)))
23f87bed 806 (max 0 (- (1+ (cddr group)) (cadr group)))
01c52d31
MB		 807 ;; Don't decode if name is ASCII
808 (if (and (fboundp 'detect-coding-string)
809 (eq (detect-coding-string name t) 'undecided))
810 name
811 (mm-decode-coding-string
812 name
813 (inline (gnus-group-name-charset method name)))))))
814 (list 'gnus-group name)
815 )))
23f87bed 816 (switch-to-buffer (current-buffer)))
eec82323
LMI		 817 (goto-char (point-min))
818 (gnus-group-position-point)
819 (gnus-message 5 "Connecting to %s...done" (nth 1 method))
820 t))))
821
822(defun gnus-browse-mode ()
823 "Major mode for browsing a foreign server.
824
825All normal editing commands are switched off.
826
827\\<gnus-browse-mode-map>
828The only things you can do in this buffer is
829
8301) `\\[gnus-browse-unsubscribe-current-group]' to subscribe to a group.
831The group will be inserted into the group buffer upon exit from this
832buffer.
833
8342) `\\[gnus-browse-read-group]' to read a group ephemerally.
835
8363) `\\[gnus-browse-exit]' to return to the group buffer."
837 (interactive)
838 (kill-all-local-variables)
839 (when (gnus-visual-p 'browse-menu 'menu)
840 (gnus-browse-make-menu-bar))
841 (gnus-simplify-mode-line)
842 (setq major-mode 'gnus-browse-mode)
843 (setq mode-name "Browse Server")
844 (setq mode-line-process nil)
845 (use-local-map gnus-browse-mode-map)
16409b0b 846 (buffer-disable-undo)
eec82323
LMI		 847 (setq truncate-lines t)
848 (gnus-set-default-directory)
849 (setq buffer-read-only t)
cfcd5c91 850 (gnus-run-mode-hooks 'gnus-browse-mode-hook))
eec82323 851
10ace8ea
MB		 852(defun gnus-browse-read-group (&optional no-article number)
853 "Enter the group at the current line.
854If NUMBER, fetch this number of articles."
855 (interactive "P")
6748645f
LMI		 856 (let ((group (gnus-browse-group-name)))
857 (if (or (not (gnus-get-info group))
858 (gnus-ephemeral-group-p group))
859 (unless (gnus-group-read-ephemeral-group
23f87bed 860 group gnus-browse-current-method nil
10ace8ea
MB		 861 (cons (current-buffer) 'browse)
862 nil nil nil number)
6748645f
LMI		 863 (error "Couldn't enter %s" group))
864 (unless (gnus-group-read-group nil no-article group)
865 (error "Couldn't enter %s" group)))))
16409b0b 866
10ace8ea
MB		 867(defun gnus-browse-select-group (&optional number)
868 "Select the current group.
869If NUMBER, fetch this number of articles."
870 (interactive "P")
871 (gnus-browse-read-group 'no number))
eec82323
LMI		 872
873(defun gnus-browse-next-group (n)
874 "Go to the next group."
875 (interactive "p")
876 (prog1
877 (forward-line n)
878 (gnus-group-position-point)))
879
880(defun gnus-browse-prev-group (n)
881 "Go to the next group."
882 (interactive "p")
883 (gnus-browse-next-group (- n)))
884
885(defun gnus-browse-unsubscribe-current-group (arg)
886 "(Un)subscribe to the next ARG groups."
887 (interactive "p")
888 (when (eobp)
a8151ef7 889 (error "No group at current line"))
eec82323
LMI		 890 (let ((ward (if (< arg 0) -1 1))
891 (arg (abs arg)))
892 (while (and (> arg 0)
893 (not (eobp))
894 (gnus-browse-unsubscribe-group)
895 (zerop (gnus-browse-next-group ward)))
896 (decf arg))
897 (gnus-group-position-point)
898 (when (/= 0 arg)
899 (gnus-message 7 "No more newsgroups"))
900 arg))
901
902(defun gnus-browse-group-name ()
903 (save-excursion
904 (beginning-of-line)
16409b0b 905 (let ((name (get-text-property (point) 'gnus-group)))
01c52d31 906 (when (re-search-forward ": \\(.*\\)$" (point-at-eol) t)
bf247b6e 907 (concat (gnus-method-to-server-name gnus-browse-current-method) ":"
23f87bed
MB		 908 (or name
909 (match-string-no-properties 1)))))))
910
911(defun gnus-browse-describe-group (group)
912 "Describe the current group."
913 (interactive (list (gnus-browse-group-name)))
914 (gnus-group-describe-group nil group))
eec82323
LMI		 915
916(defun gnus-browse-unsubscribe-group ()
917 "Toggle subscription of the current group in the browse buffer."
918 (let ((sub nil)
919 (buffer-read-only nil)
920 group)
921 (save-excursion
922 (beginning-of-line)
923 ;; If this group it killed, then we want to subscribe it.
23f87bed 924 (unless (eq (char-after) ? )
eec82323 925 (setq sub t))
6748645f 926 (setq group (gnus-browse-group-name))
23f87bed
MB		 927 (when (gnus-server-equal gnus-browse-current-method "native")
928 (setq group (gnus-group-real-name group)))
eec82323
LMI		 929 (if sub
930 (progn
6748645f
LMI		 931 ;; Make sure the group has been properly removed before we
932 ;; subscribe to it.
7ce31649
MB		 933 (if (gnus-ephemeral-group-p group)
934 (gnus-kill-ephemeral-group group))
935 ;; We need to discern between killed/zombie groups and
936 ;; just unsubscribed ones.
eec82323 937 (gnus-group-change-level
7ce31649
MB		 938 (or (gnus-group-entry group)
939 (list t group gnus-level-default-subscribed
940 nil nil (if (gnus-server-equal
941 gnus-browse-current-method "native")
942 nil
943 (gnus-method-simplify
944 gnus-browse-current-method))))
23f87bed 945 gnus-level-default-subscribed (gnus-group-level group)
eec82323 946 (and (car (nth 1 gnus-newsrc-alist))
01c52d31 947 (gnus-group-entry (car (nth 1 gnus-newsrc-alist))))
7ce31649 948 (null (gnus-group-entry group)))
23f87bed 949 (delete-char 1)
eec82323
LMI		 950 (insert ? ))
951 (gnus-group-change-level
23f87bed
MB		 952 group gnus-level-unsubscribed gnus-level-default-subscribed)
953 (delete-char 1)
954 (insert ?U)))
eec82323
LMI		 955 t))
956
957(defun gnus-browse-exit ()
958 "Quit browsing and return to the group buffer."
959 (interactive)
960 (when (eq major-mode 'gnus-browse-mode)
23f87bed 961 (gnus-kill-buffer (current-buffer)))
eec82323
LMI		 962 ;; Insert the newly subscribed groups in the group buffer.
963 (save-excursion
964 (set-buffer gnus-group-buffer)
965 (gnus-group-list-groups nil))
966 (if gnus-browse-return-buffer
967 (gnus-configure-windows 'server 'force)
968 (gnus-configure-windows 'group 'force)))
969
970(defun gnus-browse-describe-briefly ()
971 "Give a one line description of the group mode commands."
972 (interactive)
973 (gnus-message 6
974 (substitute-command-keys "\\<gnus-browse-mode-map>\\[gnus-group-next-group]:Forward \\[gnus-group-prev-group]:Backward \\[gnus-browse-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-browse-describe-briefly]:This help")))
975
976(defun gnus-server-regenerate-server ()
977 "Issue a command to the server to regenerate all its data structures."
978 (interactive)
979 (let ((server (gnus-server-server-name)))
980 (unless server
981 (error "No server on the current line"))
23f87bed
MB		 982 (condition-case ()
983 (gnus-get-function (gnus-server-to-method server)
984 'request-regenerate)
985 (error
01c52d31 986 (error "This back end doesn't support regeneration")))
23f87bed
MB		 987 (gnus-message 5 "Requesting regeneration of %s..." server)
988 (unless (gnus-open-server server)
989 (error "Couldn't open server"))
990 (if (gnus-request-regenerate server)
991 (gnus-message 5 "Requesting regeneration of %s...done" server)
992 (gnus-message 5 "Couldn't regenerate %s" server))))
eec82323 993
01c52d31
MB		 994
995;;;
996;;; Server compaction. -- dvl
997;;;
998
999;; #### FIXME: this function currently fails to update the Group buffer's
1000;; #### appearance.
1001(defun gnus-server-compact-server ()
1002 "Issue a command to the server to compact all its groups.
1003
1004Note: currently only implemented in nnml."
1005 (interactive)
1006 (let ((server (gnus-server-server-name)))
1007 (unless server
1008 (error "No server on the current line"))
1009 (condition-case ()
1010 (gnus-get-function (gnus-server-to-method server)
1011 'request-compact)
1012 (error
1013 (error "This back end doesn't support compaction")))
1014 (gnus-message 5 "\
1015Requesting compaction of %s... (this may take a long time)"
1016 server)
1017 (unless (gnus-open-server server)
1018 (error "Couldn't open server"))
1019 (if (not (gnus-request-compact server))
1020 (gnus-message 5 "Couldn't compact %s" server)
1021 (gnus-message 5 "Requesting compaction of %s...done" server)
1022 ;; Invalidate the original article buffer which might be out of date.
1023 ;; #### NOTE: Yes, this might be a bit rude, but since compaction
1024 ;; #### will not happen very often, I think this is acceptable.
1025 (let ((original (get-buffer gnus-original-article-buffer)))
1026 (and original (gnus-kill-buffer original))))))
1027
eec82323
LMI		 1028(provide 'gnus-srvr)
1029
cbee283d 1030;; arch-tag: c0117f64-27ca-475d-9406-8da6854c7a25
715a2ca2 1031;;; gnus-srvr.el ends here
Unnamed repository; edit this file 'description' to name the repository.