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