Mercurial > emacs

comparison lisp/gnus/gnus-srvr.el @ 82951:0fde48feb604

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import Gnus 5.10 from the v5_10 branch of the Gnus repository.
author Andreas Schwab <schwab@suse.de>
date Thu, 22 Jul 2004 16:45:51 +0000
parents 3227aa4e7994
children 497f0d2ca551 cce1c0ee76ee
comparison
equal deleted inserted replaced
56503:8bbd2323fbf2 82951:0fde48feb604
1 ;;; gnus-srvr.el --- virtual server support for Gnus 1 ;;; gnus-srvr.el --- virtual server support for Gnus
2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001 2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
3 ;; Free Software Foundation, Inc. 3 ;; Free Software Foundation, Inc.
4 4
5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> 5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
6 ;; Keywords: news 6 ;; Keywords: news
7 7
32 (require 'gnus-spec) 32 (require 'gnus-spec)
33 (require 'gnus-group) 33 (require 'gnus-group)
34 (require 'gnus-int) 34 (require 'gnus-int)
35 (require 'gnus-range) 35 (require 'gnus-range)
36 36
37 (defvar gnus-server-mode-hook nil 37 (defcustom gnus-server-mode-hook nil
38 "Hook run in `gnus-server-mode' buffers.") 38 "Hook run in `gnus-server-mode' buffers."
39 39 :group 'gnus-server
40 (defconst gnus-server-line-format " {%(%h:%w%)} %s\n" 40 :type 'hook)
41
42 (defcustom gnus-server-exit-hook nil
43 "Hook run when exiting the server buffer."
44 :group 'gnus-server
45 :type 'hook)
46
47 (defcustom gnus-server-line-format " {%(%h:%w%)} %s%a\n"
41 "Format of server lines. 48 "Format of server lines.
42 It works along the same lines as a normal formatting string, 49 It works along the same lines as a normal formatting string,
43 with some simple extensions. 50 with some simple extensions.
44 51
45 The following specs are understood: 52 The following specs are understood:
46 53
47 %h backend 54 %h backend
48 %n name 55 %n name
49 %w address 56 %w address
50 %s status") 57 %s status
51 58 %a agent covered
52 (defvar gnus-server-mode-line-format "Gnus: %%b" 59
53 "The format specification for the server mode line.") 60 General format specifiers can also be used.
54 61 See Info node `(gnus)Formatting Variables'."
55 (defvar gnus-server-exit-hook nil 62 :link '(custom-manual "(gnus)Formatting Variables")
56 "*Hook run when exiting the server buffer.") 63 :group 'gnus-server-visual
64 :type 'string)
65
66 (defcustom gnus-server-mode-line-format "Gnus: %%b"
67 "The format specification for the server mode line."
68 :group 'gnus-server-visual
69 :type 'string)
70
71 (defcustom gnus-server-browse-in-group-buffer nil
72 "Whether server browsing should take place in the group buffer.
73 If nil, a faster, but more primitive, buffer is used instead."
74 :group 'gnus-server-visual
75 :type 'boolean)
57 76
58 ;;; Internal variables. 77 ;;; Internal variables.
59 78
60 (defvar gnus-inserted-opened-servers nil) 79 (defvar gnus-inserted-opened-servers nil)
61 80
62 (defvar gnus-server-line-format-alist 81 (defvar gnus-server-line-format-alist
63 `((?h gnus-tmp-how ?s) 82 `((?h gnus-tmp-how ?s)
64 (?n gnus-tmp-name ?s) 83 (?n gnus-tmp-name ?s)
65 (?w gnus-tmp-where ?s) 84 (?w gnus-tmp-where ?s)
66 (?s gnus-tmp-status ?s))) 85 (?s gnus-tmp-status ?s)
86 (?a gnus-tmp-agent ?s)))
67 87
68 (defvar gnus-server-mode-line-format-alist 88 (defvar gnus-server-mode-line-format-alist
69 `((?S gnus-tmp-news-server ?s) 89 `((?S gnus-tmp-news-server ?s)
70 (?M gnus-tmp-news-method ?s) 90 (?M gnus-tmp-news-method ?s)
71 (?u gnus-tmp-user-defined ?s))) 91 (?u gnus-tmp-user-defined ?s)))
83 (gnus-turn-off-edit-menu 'server) 103 (gnus-turn-off-edit-menu 'server)
84 (unless (boundp 'gnus-server-server-menu) 104 (unless (boundp 'gnus-server-server-menu)
85 (easy-menu-define 105 (easy-menu-define
86 gnus-server-server-menu gnus-server-mode-map "" 106 gnus-server-server-menu gnus-server-mode-map ""
87 '("Server" 107 '("Server"
88 ["Add" gnus-server-add-server t] 108 ["Add..." gnus-server-add-server t]
89 ["Browse" gnus-server-read-server t] 109 ["Browse" gnus-server-read-server t]
90 ["Scan" gnus-server-scan-server t] 110 ["Scan" gnus-server-scan-server t]
91 ["List" gnus-server-list-servers t] 111 ["List" gnus-server-list-servers t]
92 ["Kill" gnus-server-kill-server t] 112 ["Kill" gnus-server-kill-server t]
93 ["Yank" gnus-server-yank-server t] 113 ["Yank" gnus-server-yank-server t]
99 (easy-menu-define 119 (easy-menu-define
100 gnus-server-connections-menu gnus-server-mode-map "" 120 gnus-server-connections-menu gnus-server-mode-map ""
101 '("Connections" 121 '("Connections"
102 ["Open" gnus-server-open-server t] 122 ["Open" gnus-server-open-server t]
103 ["Close" gnus-server-close-server t] 123 ["Close" gnus-server-close-server t]
124 ["Offline" gnus-server-offline-server t]
104 ["Deny" gnus-server-deny-server t] 125 ["Deny" gnus-server-deny-server t]
105 "---" 126 "---"
106 ["Open All" gnus-server-open-all-servers t] 127 ["Open All" gnus-server-open-all-servers t]
107 ["Close All" gnus-server-close-all-servers t] 128 ["Close All" gnus-server-close-all-servers t]
108 ["Reset All" gnus-server-remove-denials t])) 129 ["Reset All" gnus-server-remove-denials t]))
115 (unless gnus-server-mode-map 136 (unless gnus-server-mode-map
116 (setq gnus-server-mode-map (make-sparse-keymap)) 137 (setq gnus-server-mode-map (make-sparse-keymap))
117 (suppress-keymap gnus-server-mode-map) 138 (suppress-keymap gnus-server-mode-map)
118 139
119 (gnus-define-keys gnus-server-mode-map 140 (gnus-define-keys gnus-server-mode-map
120 " " gnus-server-read-server 141 " " gnus-server-read-server-in-server-buffer
121 "\r" gnus-server-read-server 142 "\r" gnus-server-read-server
122 gnus-mouse-2 gnus-server-pick-server 143 gnus-mouse-2 gnus-server-pick-server
123 "q" gnus-server-exit 144 "q" gnus-server-exit
124 "l" gnus-server-list-servers 145 "l" gnus-server-list-servers
125 "k" gnus-server-kill-server 146 "k" gnus-server-kill-server
132 "O" gnus-server-open-server 153 "O" gnus-server-open-server
133 "\M-o" gnus-server-open-all-servers 154 "\M-o" gnus-server-open-all-servers
134 "C" gnus-server-close-server 155 "C" gnus-server-close-server
135 "\M-c" gnus-server-close-all-servers 156 "\M-c" gnus-server-close-all-servers
136 "D" gnus-server-deny-server 157 "D" gnus-server-deny-server
158 "L" gnus-server-offline-server
137 "R" gnus-server-remove-denials 159 "R" gnus-server-remove-denials
138 160
139 "n" next-line 161 "n" next-line
140 "p" previous-line 162 "p" previous-line
141 163
142 "g" gnus-server-regenerate-server 164 "g" gnus-server-regenerate-server
143 165
144 "\C-c\C-i" gnus-info-find-node 166 "\C-c\C-i" gnus-info-find-node
145 "\C-c\C-b" gnus-bug)) 167 "\C-c\C-b" gnus-bug))
168
169 (defface gnus-server-agent-face
170 '((((class color) (background light)) (:foreground "PaleTurquoise" :bold t))
171 (((class color) (background dark)) (:foreground "PaleTurquoise" :bold t))
172 (t (:bold t)))
173 "Face used for displaying AGENTIZED servers"
174 :group 'gnus-server-visual)
175
176 (defface gnus-server-opened-face
177 '((((class color) (background light)) (:foreground "Green3" :bold t))
178 (((class color) (background dark)) (:foreground "Green1" :bold t))
179 (t (:bold t)))
180 "Face used for displaying OPENED servers"
181 :group 'gnus-server-visual)
182
183 (defface gnus-server-closed-face
184 '((((class color) (background light)) (:foreground "Steel Blue" :italic t))
185 (((class color) (background dark))
186 (:foreground "Light Steel Blue" :italic t))
187 (t (:italic t)))
188 "Face used for displaying CLOSED servers"
189 :group 'gnus-server-visual)
190
191 (defface gnus-server-denied-face
192 '((((class color) (background light)) (:foreground "Red" :bold t))
193 (((class color) (background dark)) (:foreground "Pink" :bold t))
194 (t (:inverse-video t :bold t)))
195 "Face used for displaying DENIED servers"
196 :group 'gnus-server-visual)
197
198 (defface gnus-server-offline-face
199 '((((class color) (background light)) (:foreground "Orange" :bold t))
200 (((class color) (background dark)) (:foreground "Yellow" :bold t))
201 (t (:inverse-video t :bold t)))
202 "Face used for displaying OFFLINE servers"
203 :group 'gnus-server-visual)
204
205 (defcustom gnus-server-agent-face 'gnus-server-agent-face
206 "Face name to use on AGENTIZED servers."
207 :group 'gnus-server-visual
208 :type 'face)
209
210 (defcustom gnus-server-opened-face 'gnus-server-opened-face
211 "Face name to use on OPENED servers."
212 :group 'gnus-server-visual
213 :type 'face)
214
215 (defcustom gnus-server-closed-face 'gnus-server-closed-face
216 "Face name to use on CLOSED servers."
217 :group 'gnus-server-visual
218 :type 'face)
219
220 (defcustom gnus-server-denied-face 'gnus-server-denied-face
221 "Face name to use on DENIED servers."
222 :group 'gnus-server-visual
223 :type 'face)
224
225 (defcustom gnus-server-offline-face 'gnus-server-offline-face
226 "Face name to use on OFFLINE servers."
227 :group 'gnus-server-visual
228 :type 'face)
229
230 (defvar gnus-server-font-lock-keywords
231 (list
232 '("(\\(agent\\))" 1 gnus-server-agent-face)
233 '("(\\(opened\\))" 1 gnus-server-opened-face)
234 '("(\\(closed\\))" 1 gnus-server-closed-face)
235 '("(\\(offline\\))" 1 gnus-server-offline-face)
236 '("(\\(denied\\))" 1 gnus-server-denied-face)))
146 237
147 (defun gnus-server-mode () 238 (defun gnus-server-mode ()
148 "Major mode for listing and editing servers. 239 "Major mode for listing and editing servers.
149 240
150 All normal editing commands are switched off. 241 All normal editing commands are switched off.
166 (setq mode-line-process nil) 257 (setq mode-line-process nil)
167 (use-local-map gnus-server-mode-map) 258 (use-local-map gnus-server-mode-map)
168 (buffer-disable-undo) 259 (buffer-disable-undo)
169 (setq truncate-lines t) 260 (setq truncate-lines t)
170 (setq buffer-read-only t) 261 (setq buffer-read-only t)
262 (if (featurep 'xemacs)
263 (put 'gnus-server-mode 'font-lock-defaults '(gnus-server-font-lock-keywords t))
264 (set (make-local-variable 'font-lock-defaults)
265 '(gnus-server-font-lock-keywords t)))
171 (gnus-run-hooks 'gnus-server-mode-hook)) 266 (gnus-run-hooks 'gnus-server-mode-hook))
172 267
173 (defun gnus-server-insert-server-line (gnus-tmp-name method) 268 (defun gnus-server-insert-server-line (gnus-tmp-name method)
174 (let* ((gnus-tmp-how (car method)) 269 (let* ((gnus-tmp-how (car method))
175 (gnus-tmp-where (nth 1 method)) 270 (gnus-tmp-where (nth 1 method))
176 (elem (assoc method gnus-opened-servers)) 271 (elem (assoc method gnus-opened-servers))
177 (gnus-tmp-status 272 (gnus-tmp-status
178 (if (eq (nth 1 elem) 'denied) 273 (cond
179 "(denied)" 274 ((eq (nth 1 elem) 'denied) "(denied)")
275 ((eq (nth 1 elem) 'offline) "(offline)")
276 (t
180 (condition-case nil 277 (condition-case nil
181 (if (or (gnus-server-opened method) 278 (if (or (gnus-server-opened method)
182 (eq (nth 1 elem) 'ok)) 279 (eq (nth 1 elem) 'ok))
183 "(opened)" 280 "(opened)"
184 "(closed)") 281 "(closed)")
185 ((error) "(error)"))))) 282 ((error) "(error)")))))
283 (gnus-tmp-agent (if (and gnus-agent
284 (gnus-agent-method-p method))
285 " (agent)"
286 "")))
186 (beginning-of-line) 287 (beginning-of-line)
187 (gnus-add-text-properties 288 (gnus-add-text-properties
188 (point) 289 (point)
189 (prog1 (1+ (point)) 290 (prog1 (1+ (point))
190 ;; Insert the text. 291 ;; Insert the text.
191 (eval gnus-server-line-format-spec)) 292 (eval gnus-server-line-format-spec))
192 (list 'gnus-server (intern gnus-tmp-name))))) 293 (list 'gnus-server (intern gnus-tmp-name)
294 'gnus-named-server (intern (gnus-method-to-server method))))))
193 295
194 (defun gnus-enter-server-buffer () 296 (defun gnus-enter-server-buffer ()
195 "Set up the server buffer." 297 "Set up the server buffer."
196 (gnus-server-setup-buffer) 298 (gnus-server-setup-buffer)
197 (gnus-configure-windows 'server) 299 (gnus-configure-windows 'server)
241 343
242 (defun gnus-server-server-name () 344 (defun gnus-server-server-name ()
243 (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server))) 345 (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server)))
244 (and server (symbol-name server)))) 346 (and server (symbol-name server))))
245 347
348 (defun gnus-server-named-server ()
349 "Returns a server name that matches one of the names returned by
350 gnus-method-to-server."
351 (let ((server (get-text-property (gnus-point-at-bol) 'gnus-named-server)))
352 (and server (symbol-name server))))
353
246 (defalias 'gnus-server-position-point 'gnus-goto-colon) 354 (defalias 'gnus-server-position-point 'gnus-goto-colon)
247 355
248 (defconst gnus-server-edit-buffer "*Gnus edit server*") 356 (defconst gnus-server-edit-buffer "*Gnus edit server*")
249 357
250 (defun gnus-server-update-server (server) 358 (defun gnus-server-update-server (server)
255 (oentry (assoc (gnus-server-to-method server) 363 (oentry (assoc (gnus-server-to-method server)
256 gnus-opened-servers))) 364 gnus-opened-servers)))
257 (when entry 365 (when entry
258 (gnus-dribble-enter 366 (gnus-dribble-enter
259 (concat "(gnus-server-set-info \"" server "\" '" 367 (concat "(gnus-server-set-info \"" server "\" '"
260 (prin1-to-string (cdr entry)) ")\n"))) 368 (gnus-prin1-to-string (cdr entry)) ")\n")))
261 (when (or entry oentry) 369 (when (or entry oentry)
262 ;; Buffer may be narrowed. 370 ;; Buffer may be narrowed.
263 (save-restriction 371 (save-restriction
264 (widen) 372 (widen)
265 (when (gnus-server-goto-server server) 373 (when (gnus-server-goto-server server)
274 (defun gnus-server-set-info (server info) 382 (defun gnus-server-set-info (server info)
275 ;; Enter a select method into the virtual server alist. 383 ;; Enter a select method into the virtual server alist.
276 (when (and server info) 384 (when (and server info)
277 (gnus-dribble-enter 385 (gnus-dribble-enter
278 (concat "(gnus-server-set-info \"" server "\" '" 386 (concat "(gnus-server-set-info \"" server "\" '"
279 (prin1-to-string info) ")")) 387 (gnus-prin1-to-string info) ")"))
280 (let* ((server (nth 1 info)) 388 (let* ((server (nth 1 info))
281 (entry (assoc server gnus-server-alist))) 389 (entry (assoc server gnus-server-alist))
390 (cached (assoc server gnus-server-method-cache)))
391 (if cached
392 (setq gnus-server-method-cache
393 (delq cached gnus-server-method-cache)))
282 (if entry (setcdr entry info) 394 (if entry (setcdr entry info)
283 (setq gnus-server-alist 395 (setq gnus-server-alist
284 (nconc gnus-server-alist (list (cons server info)))))))) 396 (nconc gnus-server-alist (list (cons server info))))))))
285 397
286 ;;; Interactive server functions. 398 ;;; Interactive server functions.
328 (while (and (cdr alist) 440 (while (and (cdr alist)
329 (not (string= server (caadr alist)))) 441 (not (string= server (caadr alist))))
330 (setq alist (cdr alist))) 442 (setq alist (cdr alist)))
331 (if alist 443 (if alist
332 (setcdr alist (cons killed (cdr alist))) 444 (setcdr alist (cons killed (cdr alist)))
333 (setq gnus-server-alist (list killed))))) 445 (setq gnus-server-alist (list killed)))))
334 (gnus-server-update-server (car killed)) 446 (gnus-server-update-server (car killed))
335 (setq gnus-server-killed-servers (cdr gnus-server-killed-servers)) 447 (setq gnus-server-killed-servers (cdr gnus-server-killed-servers))
336 (gnus-server-position-point))) 448 (gnus-server-position-point)))
337 449
338 (defun gnus-server-exit () 450 (defun gnus-server-exit ()
339 "Return to the group buffer." 451 "Return to the group buffer."
340 (interactive) 452 (interactive)
341 (gnus-run-hooks 'gnus-server-exit-hook) 453 (gnus-run-hooks 'gnus-server-exit-hook)
342 (kill-buffer (current-buffer)) 454 (gnus-kill-buffer (current-buffer))
343 (gnus-configure-windows 'group t)) 455 (gnus-configure-windows 'group t))
344 456
345 (defun gnus-server-list-servers () 457 (defun gnus-server-list-servers ()
346 "List all available servers." 458 "List all available servers."
347 (interactive) 459 (interactive)
394 (prog1 506 (prog1
395 (gnus-close-server method) 507 (gnus-close-server method)
396 (gnus-server-update-server server) 508 (gnus-server-update-server server)
397 (gnus-server-position-point)))) 509 (gnus-server-position-point))))
398 510
511 (defun gnus-server-offline-server (server)
512 "Set SERVER to offline."
513 (interactive (list (gnus-server-server-name)))
514 (let ((method (gnus-server-to-method server)))
515 (unless method
516 (error "No such server: %s" server))
517 (prog1
518 (gnus-close-server method)
519 (gnus-server-set-status method 'offline)
520 (gnus-server-update-server server)
521 (gnus-server-position-point))))
522
399 (defun gnus-server-close-all-servers () 523 (defun gnus-server-close-all-servers ()
400 "Close all servers." 524 "Close all servers."
401 (interactive) 525 (interactive)
402 (let ((servers gnus-inserted-opened-servers)) 526 (dolist (server gnus-inserted-opened-servers)
403 (while servers 527 (gnus-server-close-server (car server))))
404 (gnus-server-close-server (car (pop servers))))))
405 528
406 (defun gnus-server-deny-server (server) 529 (defun gnus-server-deny-server (server)
407 "Make sure SERVER will never be attempted opened." 530 "Make sure SERVER will never be attempted opened."
408 (interactive (list (gnus-server-server-name))) 531 (interactive (list (gnus-server-server-name)))
409 (let ((method (gnus-server-to-method server))) 532 (let ((method (gnus-server-to-method server)))
415 t) 538 t)
416 539
417 (defun gnus-server-remove-denials () 540 (defun gnus-server-remove-denials ()
418 "Make all denied servers into closed servers." 541 "Make all denied servers into closed servers."
419 (interactive) 542 (interactive)
420 (let ((servers gnus-opened-servers)) 543 (dolist (server gnus-opened-servers)
421 (while servers 544 (when (eq (nth 1 server) 'denied)
422 (when (eq (nth 1 (car servers)) 'denied) 545 (setcar (nthcdr 1 server) 'closed)))
423 (setcar (nthcdr 1 (car servers)) 'closed))
424 (setq servers (cdr servers))))
425 (gnus-server-list-servers)) 546 (gnus-server-list-servers))
426 547
427 (defun gnus-server-copy-server (from to) 548 (defun gnus-server-copy-server (from to)
428 (interactive 549 (interactive
429 (list 550 (list
489 (error "Server %s can't scan" (car method)) 610 (error "Server %s can't scan" (car method))
490 (gnus-message 3 "Scanning %s..." server) 611 (gnus-message 3 "Scanning %s..." server)
491 (gnus-request-scan nil method) 612 (gnus-request-scan nil method)
492 (gnus-message 3 "Scanning %s...done" server)))) 613 (gnus-message 3 "Scanning %s...done" server))))
493 614
615 (defun gnus-server-read-server-in-server-buffer (server)
616 "Browse a server in server buffer."
617 (interactive (list (gnus-server-server-name)))
618 (let (gnus-server-browse-in-group-buffer)
619 (gnus-server-read-server server)))
620
494 (defun gnus-server-read-server (server) 621 (defun gnus-server-read-server (server)
495 "Browse a server." 622 "Browse a server."
496 (interactive (list (gnus-server-server-name))) 623 (interactive (list (gnus-server-server-name)))
497 (let ((buf (current-buffer))) 624 (let ((buf (current-buffer)))
498 (prog1 625 (prog1
539 "u" gnus-browse-unsubscribe-current-group 666 "u" gnus-browse-unsubscribe-current-group
540 "l" gnus-browse-exit 667 "l" gnus-browse-exit
541 "L" gnus-browse-exit 668 "L" gnus-browse-exit
542 "q" gnus-browse-exit 669 "q" gnus-browse-exit
543 "Q" gnus-browse-exit 670 "Q" gnus-browse-exit
671 "d" gnus-browse-describe-group
544 "\C-c\C-c" gnus-browse-exit 672 "\C-c\C-c" gnus-browse-exit
545 "?" gnus-browse-describe-briefly 673 "?" gnus-browse-describe-briefly
546 674
547 "\C-c\C-i" gnus-info-find-node 675 "\C-c\C-i" gnus-info-find-node
548 "\C-c\C-b" gnus-bug)) 676 "\C-c\C-b" gnus-bug))
554 gnus-browse-menu gnus-browse-mode-map "" 682 gnus-browse-menu gnus-browse-mode-map ""
555 '("Browse" 683 '("Browse"
556 ["Subscribe" gnus-browse-unsubscribe-current-group t] 684 ["Subscribe" gnus-browse-unsubscribe-current-group t]
557 ["Read" gnus-browse-read-group t] 685 ["Read" gnus-browse-read-group t]
558 ["Select" gnus-browse-select-group t] 686 ["Select" gnus-browse-select-group t]
687 ["Describe" gnus-browse-describe-group t]
559 ["Next" gnus-browse-next-group t] 688 ["Next" gnus-browse-next-group t]
560 ["Prev" gnus-browse-prev-group t] 689 ["Prev" gnus-browse-prev-group t]
561 ["Exit" gnus-browse-exit t])) 690 ["Exit" gnus-browse-exit t]))
562 (gnus-run-hooks 'gnus-browse-menu-hook))) 691 (gnus-run-hooks 'gnus-browse-menu-hook)))
563 692
569 (defun gnus-browse-foreign-server (server &optional return-buffer) 698 (defun gnus-browse-foreign-server (server &optional return-buffer)
570 "Browse the server SERVER." 699 "Browse the server SERVER."
571 (setq gnus-browse-current-method (gnus-server-to-method server)) 700 (setq gnus-browse-current-method (gnus-server-to-method server))
572 (setq gnus-browse-return-buffer return-buffer) 701 (setq gnus-browse-return-buffer return-buffer)
573 (let* ((method gnus-browse-current-method) 702 (let* ((method gnus-browse-current-method)
703 (orig-select-method gnus-select-method)
574 (gnus-select-method method) 704 (gnus-select-method method)
575 groups group) 705 groups group)
576 (gnus-message 5 "Connecting to %s..." (nth 1 method)) 706 (gnus-message 5 "Connecting to %s..." (nth 1 method))
577 (cond 707 (cond
578 ((not (gnus-check-server method)) 708 ((not (gnus-check-server method))
587 (gnus-message 6 "Reading active file...done"))) 717 (gnus-message 6 "Reading active file...done")))
588 (gnus-message 718 (gnus-message
589 1 "Couldn't request list: %s" (gnus-status-message method)) 719 1 "Couldn't request list: %s" (gnus-status-message method))
590 nil) 720 nil)
591 (t 721 (t
592 (gnus-get-buffer-create gnus-browse-buffer) 722 (with-current-buffer nntp-server-buffer
593 (when gnus-carpal
594 (gnus-carpal-setup-buffer 'browse))
595 (gnus-configure-windows 'browse)
596 (buffer-disable-undo)
597 (let ((buffer-read-only nil))
598 (erase-buffer))
599 (gnus-browse-mode)
600 (setq mode-line-buffer-identification
601 (list
602 (format
603 "Gnus: %%b {%s:%s}" (car method) (cadr method))))
604 (save-excursion
605 (set-buffer nntp-server-buffer)
606 (let ((cur (current-buffer))) 723 (let ((cur (current-buffer)))
607 (goto-char (point-min)) 724 (goto-char (point-min))
608 (unless (string= gnus-ignored-newsgroups "") 725 (unless (string= gnus-ignored-newsgroups "")
609 (delete-matching-lines gnus-ignored-newsgroups)) 726 (delete-matching-lines gnus-ignored-newsgroups))
610 (while (not (eobp)) 727 ;; We treat NNTP as a special case to avoid problems with
611 (ignore-errors 728 ;; garbage group names like `"foo' that appear in some badly
612 (push (cons 729 ;; managed active files. -jh.
613 (if (eq (char-after) ?\") 730 (if (eq (car method) 'nntp)
614 (read cur) 731 (while (not (eobp))
615 (let ((p (point)) (name "")) 732 (ignore-errors
616 (skip-chars-forward "^ \t\\\\") 733 (push (cons
617 (setq name (buffer-substring p (point))) 734 (buffer-substring
618 (while (eq (char-after) ?\\) 735 (point)
619 (setq p (1+ (point))) 736 (progn
620 (forward-char 2) 737 (skip-chars-forward "^ \t")
738 (point)))
739 (let ((last (read cur)))
740 (cons (read cur) last)))
741 groups))
742 (forward-line))
743 (while (not (eobp))
744 (ignore-errors
745 (push (cons
746 (if (eq (char-after) ?\")
747 (read cur)
748 (let ((p (point)) (name ""))
621 (skip-chars-forward "^ \t\\\\") 749 (skip-chars-forward "^ \t\\\\")
622 (setq name (concat name (buffer-substring 750 (setq name (buffer-substring p (point)))
623 p (point))))) 751 (while (eq (char-after) ?\\)
624 name)) 752 (setq p (1+ (point)))
625 (max 0 (- (1+ (read cur)) (read cur)))) 753 (forward-char 2)
626 groups)) 754 (skip-chars-forward "^ \t\\\\")
627 (forward-line)))) 755 (setq name (concat name (buffer-substring
756 p (point)))))
757 name))
758 (let ((last (read cur)))
759 (cons (read cur) last)))
760 groups))
761 (forward-line)))))
628 (setq groups (sort groups 762 (setq groups (sort groups
629 (lambda (l1 l2) 763 (lambda (l1 l2)
630 (string< (car l1) (car l2))))) 764 (string< (car l1) (car l2)))))
631 (let ((buffer-read-only nil) charset) 765 (if gnus-server-browse-in-group-buffer
632 (while groups 766 (let* ((gnus-select-method orig-select-method)
633 (setq group (car groups)) 767 (gnus-group-listed-groups
634 (setq charset (gnus-group-name-charset method group)) 768 (mapcar (lambda (group)
635 (gnus-add-text-properties 769 (let ((name
636 (point) 770 (gnus-group-prefixed-name
637 (prog1 (1+ (point)) 771 (car group) method)))
638 (insert 772 (gnus-set-active name (cdr group))
639 (format "K%7d: %s\n" (cdr group) 773 name))
640 (gnus-group-name-decode (car group) charset)))) 774 groups)))
641 (list 'gnus-group (car group))) 775 (gnus-configure-windows 'group)
642 (setq groups (cdr groups)))) 776 (funcall gnus-group-prepare-function
643 (switch-to-buffer (current-buffer)) 777 gnus-level-killed 'ignore 1 'ignore))
778 (gnus-get-buffer-create gnus-browse-buffer)
779 (when gnus-carpal
780 (gnus-carpal-setup-buffer 'browse))
781 (gnus-configure-windows 'browse)
782 (buffer-disable-undo)
783 (let ((buffer-read-only nil))
784 (erase-buffer))
785 (gnus-browse-mode)
786 (setq mode-line-buffer-identification
787 (list
788 (format
789 "Gnus: %%b {%s:%s}" (car method) (cadr method))))
790 (let ((buffer-read-only nil)
791 name
792 (prefix (let ((gnus-select-method orig-select-method))
793 (gnus-group-prefixed-name "" method))))
794 (while (setq group (pop groups))
795 (gnus-add-text-properties
796 (point)
797 (prog1 (1+ (point))
798 (insert
799 (format "%c%7d: %s\n"
800 (let ((level (gnus-group-level
801 (concat prefix (setq name (car group))))))
802 (cond
803 ((<= level gnus-level-subscribed) ? )
804 ((<= level gnus-level-unsubscribed) ?U)
805 ((= level gnus-level-zombie) ?Z)
806 (t ?K)))
807 (max 0 (- (1+ (cddr group)) (cadr group)))
808 (mm-decode-coding-string
809 name
810 (inline (gnus-group-name-charset method name))))))
811 (list 'gnus-group name))))
812 (switch-to-buffer (current-buffer)))
644 (goto-char (point-min)) 813 (goto-char (point-min))
645 (gnus-group-position-point) 814 (gnus-group-position-point)
646 (gnus-message 5 "Connecting to %s...done" (nth 1 method)) 815 (gnus-message 5 "Connecting to %s...done" (nth 1 method))
647 t)))) 816 t))))
648 817
681 (interactive) 850 (interactive)
682 (let ((group (gnus-browse-group-name))) 851 (let ((group (gnus-browse-group-name)))
683 (if (or (not (gnus-get-info group)) 852 (if (or (not (gnus-get-info group))
684 (gnus-ephemeral-group-p group)) 853 (gnus-ephemeral-group-p group))
685 (unless (gnus-group-read-ephemeral-group 854 (unless (gnus-group-read-ephemeral-group
686 (gnus-group-real-name group) gnus-browse-current-method nil 855 group gnus-browse-current-method nil
687 (cons (current-buffer) 'browse)) 856 (cons (current-buffer) 'browse))
688 (error "Couldn't enter %s" group)) 857 (error "Couldn't enter %s" group))
689 (unless (gnus-group-read-group nil no-article group) 858 (unless (gnus-group-read-group nil no-article group)
690 (error "Couldn't enter %s" group))))) 859 (error "Couldn't enter %s" group)))))
691 860
726 (defun gnus-browse-group-name () 895 (defun gnus-browse-group-name ()
727 (save-excursion 896 (save-excursion
728 (beginning-of-line) 897 (beginning-of-line)
729 (let ((name (get-text-property (point) 'gnus-group))) 898 (let ((name (get-text-property (point) 'gnus-group)))
730 (when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t) 899 (when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t)
731 (gnus-group-prefixed-name 900 (concat (gnus-method-to-server-name gnus-browse-current-method) ":"
732 (or name 901 (or name
733 (match-string-no-properties 1)) 902 (match-string-no-properties 1)))))))
734 gnus-browse-current-method))))) 903
904 (defun gnus-browse-describe-group (group)
905 "Describe the current group."
906 (interactive (list (gnus-browse-group-name)))
907 (gnus-group-describe-group nil group))
735 908
736 (defun gnus-browse-unsubscribe-group () 909 (defun gnus-browse-unsubscribe-group ()
737 "Toggle subscription of the current group in the browse buffer." 910 "Toggle subscription of the current group in the browse buffer."
738 (let ((sub nil) 911 (let ((sub nil)
739 (buffer-read-only nil) 912 (buffer-read-only nil)
740 group) 913 group)
741 (save-excursion 914 (save-excursion
742 (beginning-of-line) 915 (beginning-of-line)
743 ;; If this group it killed, then we want to subscribe it. 916 ;; If this group it killed, then we want to subscribe it.
744 (when (eq (char-after) ?K) 917 (unless (eq (char-after) ? )
745 (setq sub t)) 918 (setq sub t))
746 (setq group (gnus-browse-group-name)) 919 (setq group (gnus-browse-group-name))
747 (when (and sub 920 (when (gnus-server-equal gnus-browse-current-method "native")
748 (cadr (gnus-gethash group gnus-newsrc-hashtb))) 921 (setq group (gnus-group-real-name group)))
749 (error "Group already subscribed"))
750 (delete-char 1)
751 (if sub 922 (if sub
752 (progn 923 (progn
753 ;; Make sure the group has been properly removed before we 924 ;; Make sure the group has been properly removed before we
754 ;; subscribe to it. 925 ;; subscribe to it.
755 (gnus-kill-ephemeral-group group) 926 (gnus-kill-ephemeral-group group)
758 nil nil (if (gnus-server-equal 929 nil nil (if (gnus-server-equal
759 gnus-browse-current-method "native") 930 gnus-browse-current-method "native")
760 nil 931 nil
761 (gnus-method-simplify 932 (gnus-method-simplify
762 gnus-browse-current-method))) 933 gnus-browse-current-method)))
763 gnus-level-default-subscribed gnus-level-killed 934 gnus-level-default-subscribed (gnus-group-level group)
764 (and (car (nth 1 gnus-newsrc-alist)) 935 (and (car (nth 1 gnus-newsrc-alist))
765 (gnus-gethash (car (nth 1 gnus-newsrc-alist)) 936 (gnus-gethash (car (nth 1 gnus-newsrc-alist))
766 gnus-newsrc-hashtb)) 937 gnus-newsrc-hashtb))
767 t) 938 t)
939 (delete-char 1)
768 (insert ? )) 940 (insert ? ))
769 (gnus-group-change-level 941 (gnus-group-change-level
770 group gnus-level-killed gnus-level-default-subscribed) 942 group gnus-level-unsubscribed gnus-level-default-subscribed)
771 (insert ?K))) 943 (delete-char 1)
944 (insert ?U)))
772 t)) 945 t))
773 946
774 (defun gnus-browse-exit () 947 (defun gnus-browse-exit ()
775 "Quit browsing and return to the group buffer." 948 "Quit browsing and return to the group buffer."
776 (interactive) 949 (interactive)
777 (when (eq major-mode 'gnus-browse-mode) 950 (when (eq major-mode 'gnus-browse-mode)
778 (kill-buffer (current-buffer))) 951 (gnus-kill-buffer (current-buffer)))
779 ;; Insert the newly subscribed groups in the group buffer. 952 ;; Insert the newly subscribed groups in the group buffer.
780 (save-excursion 953 (save-excursion
781 (set-buffer gnus-group-buffer) 954 (set-buffer gnus-group-buffer)
782 (gnus-group-list-groups nil)) 955 (gnus-group-list-groups nil))
783 (if gnus-browse-return-buffer 956 (if gnus-browse-return-buffer
794 "Issue a command to the server to regenerate all its data structures." 967 "Issue a command to the server to regenerate all its data structures."
795 (interactive) 968 (interactive)
796 (let ((server (gnus-server-server-name))) 969 (let ((server (gnus-server-server-name)))
797 (unless server 970 (unless server
798 (error "No server on the current line")) 971 (error "No server on the current line"))
799 (if (not (gnus-check-backend-function 972 (condition-case ()
800 'request-regenerate (car (gnus-server-to-method server)))) 973 (gnus-get-function (gnus-server-to-method server)
801 (error "This backend doesn't support regeneration") 974 'request-regenerate)
802 (gnus-message 5 "Requesting regeneration of %s..." server) 975 (error
803 (unless (gnus-open-server server) 976 (error "This backend doesn't support regeneration")))
804 (error "Couldn't open server")) 977 (gnus-message 5 "Requesting regeneration of %s..." server)
805 (if (gnus-request-regenerate server) 978 (unless (gnus-open-server server)
806 (gnus-message 5 "Requesting regeneration of %s...done" server) 979 (error "Couldn't open server"))
807 (gnus-message 5 "Couldn't regenerate %s" server))))) 980 (if (gnus-request-regenerate server)
981 (gnus-message 5 "Requesting regeneration of %s...done" server)
982 (gnus-message 5 "Couldn't regenerate %s" server))))
808 983
809 (provide 'gnus-srvr) 984 (provide 'gnus-srvr)
810 985
811 ;;; arch-tag: c0117f64-27ca-475d-9406-8da6854c7a25 986 ;;; arch-tag: c0117f64-27ca-475d-9406-8da6854c7a25
812 ;;; gnus-srvr.el ends here 987 ;;; gnus-srvr.el ends here