Mercurial > emacs
comparison lisp/gnus/gnus-srvr.el @ 56927:55fd4f77387a after-merge-gnus-5_10
Revision: miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-523
Merge from emacs--gnus--5.10, gnus--rel--5.10
Patches applied:
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--base-0
tag of miles@gnu.org--gnu-2004/emacs--cvs-trunk--0--patch-464
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-1
Import from CVS branch gnus-5_10-branch
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-2
Merge from lorentey@elte.hu--2004/emacs--multi-tty--0, emacs--cvs-trunk--0
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-3
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2004/emacs--gnus--5.10--patch-4
Merge from gnus--rel--5.10
* miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-18
Update from CVS
* miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-19
Remove autoconf-generated files from archive
* miles@gnu.org--gnu-2004/gnus--rel--5.10--patch-20
Update from CVS
author | Miles Bader <miles@gnu.org> |
---|---|
date | Sat, 04 Sep 2004 13:13:48 +0000 |
parents | 3227aa4e7994 |
children | 497f0d2ca551 cce1c0ee76ee |
comparison
equal
deleted
inserted
replaced
56926:f8e248e9a717 | 56927:55fd4f77387a |
---|---|
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 |