Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-srvr.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents 8b8b7f3559a2
children 0d2f883870bc
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
1 ;;; gnus-srvr.el --- virtual server support for Gnus 1 ;;; gnus-srvr.el --- virtual server support for Gnus
2 ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc. 2 ;; Copyright (C) 1995,96 Free Software Foundation, Inc.
3 3
4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no> 4 ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
5 ;; Keywords: news 5 ;; Keywords: news
6 6
7 ;; This file is part of GNU Emacs. 7 ;; This file is part of GNU Emacs.
24 ;;; Commentary: 24 ;;; Commentary:
25 25
26 ;;; Code: 26 ;;; Code:
27 27
28 (require 'gnus) 28 (require 'gnus)
29 (require 'gnus-spec) 29 (eval-when-compile (require 'cl))
30 (require 'gnus-group)
31 (require 'gnus-int)
32 (require 'gnus-range)
33 30
34 (defvar gnus-server-mode-hook nil 31 (defvar gnus-server-mode-hook nil
35 "Hook run in `gnus-server-mode' buffers.") 32 "Hook run in `gnus-server-mode' buffers.")
36 33
37 (defconst gnus-server-line-format " {%(%h:%w%)} %s\n" 34 (defconst gnus-server-line-format " {%(%h:%w%)} %s\n"
53 `((?h how ?s) 50 `((?h how ?s)
54 (?n name ?s) 51 (?n name ?s)
55 (?w where ?s) 52 (?w where ?s)
56 (?s status ?s))) 53 (?s status ?s)))
57 54
58 (defvar gnus-server-mode-line-format-alist 55 (defvar gnus-server-mode-line-format-alist
59 `((?S news-server ?s) 56 `((?S news-server ?s)
60 (?M news-method ?s) 57 (?M news-method ?s)
61 (?u user-defined ?s))) 58 (?u user-defined ?s)))
62 59
63 (defvar gnus-server-line-format-spec nil) 60 (defvar gnus-server-line-format-spec nil)
68 65
69 (defvar gnus-server-menu-hook nil 66 (defvar gnus-server-menu-hook nil
70 "*Hook run after the creation of the server mode menu.") 67 "*Hook run after the creation of the server mode menu.")
71 68
72 (defun gnus-server-make-menu-bar () 69 (defun gnus-server-make-menu-bar ()
73 (gnus-turn-off-edit-menu 'server) 70 (gnus-visual-turn-off-edit-menu 'server)
74 (unless (boundp 'gnus-server-server-menu) 71 (unless (boundp 'gnus-server-server-menu)
75 (easy-menu-define 72 (easy-menu-define
76 gnus-server-server-menu gnus-server-mode-map "" 73 gnus-server-server-menu gnus-server-mode-map ""
77 '("Server" 74 '("Server"
78 ["Add" gnus-server-add-server t] 75 ["Add" gnus-server-add-server t]
79 ["Browse" gnus-server-read-server t] 76 ["Browse" gnus-server-read-server t]
80 ["Scan" gnus-server-scan-server t]
81 ["List" gnus-server-list-servers t] 77 ["List" gnus-server-list-servers t]
82 ["Kill" gnus-server-kill-server t] 78 ["Kill" gnus-server-kill-server t]
83 ["Yank" gnus-server-yank-server t] 79 ["Yank" gnus-server-yank-server t]
84 ["Copy" gnus-server-copy-server t] 80 ["Copy" gnus-server-copy-server t]
85 ["Edit" gnus-server-edit-server t] 81 ["Edit" gnus-server-edit-server t]
86 ["Regenerate" gnus-server-regenerate-server t] 82 ["Exit" gnus-server-exit t]
87 ["Exit" gnus-server-exit t])) 83 ))
88 84
89 (easy-menu-define 85 (easy-menu-define
90 gnus-server-connections-menu gnus-server-mode-map "" 86 gnus-server-connections-menu gnus-server-mode-map ""
91 '("Connections" 87 '("Connections"
92 ["Open" gnus-server-open-server t] 88 ["Open" gnus-server-open-server t]
93 ["Close" gnus-server-close-server t] 89 ["Close" gnus-server-close-server t]
94 ["Deny" gnus-server-deny-server t] 90 ["Deny" gnus-server-deny-server t]
95 "---" 91 ["Reset" gnus-server-remove-denials t]
96 ["Open All" gnus-server-open-all-servers t] 92 ))
97 ["Close All" gnus-server-close-all-servers t]
98 ["Reset All" gnus-server-remove-denials t]))
99 93
100 (run-hooks 'gnus-server-menu-hook))) 94 (run-hooks 'gnus-server-menu-hook)))
101 95
102 (defvar gnus-server-mode-map nil) 96 (defvar gnus-server-mode-map nil)
103 (put 'gnus-server-mode 'mode-class 'special) 97 (put 'gnus-server-mode 'mode-class 'special)
116 "k" gnus-server-kill-server 110 "k" gnus-server-kill-server
117 "y" gnus-server-yank-server 111 "y" gnus-server-yank-server
118 "c" gnus-server-copy-server 112 "c" gnus-server-copy-server
119 "a" gnus-server-add-server 113 "a" gnus-server-add-server
120 "e" gnus-server-edit-server 114 "e" gnus-server-edit-server
121 "s" gnus-server-scan-server
122 115
123 "O" gnus-server-open-server 116 "O" gnus-server-open-server
124 "\M-o" gnus-server-open-all-servers
125 "C" gnus-server-close-server 117 "C" gnus-server-close-server
126 "\M-c" gnus-server-close-all-servers
127 "D" gnus-server-deny-server 118 "D" gnus-server-deny-server
128 "R" gnus-server-remove-denials 119 "R" gnus-server-remove-denials
129 120
130 "g" gnus-server-regenerate-server 121 "\C-c\C-i" gnus-info-find-node))
131
132 "\C-c\C-i" gnus-info-find-node
133 "\C-c\C-b" gnus-bug))
134 122
135 (defun gnus-server-mode () 123 (defun gnus-server-mode ()
136 "Major mode for listing and editing servers. 124 "Major mode for listing and editing servers.
137 125
138 All normal editing commands are switched off. 126 All normal editing commands are switched off.
139 \\<gnus-server-mode-map> 127 \\<gnus-server-mode-map>
140 For more in-depth information on this mode, read the manual 128 For more in-depth information on this mode, read the manual
141 (`\\[gnus-info-find-node]'). 129 (`\\[gnus-info-find-node]').
142 130
143 The following commands are available: 131 The following commands are available:
144 132
145 \\{gnus-server-mode-map}" 133 \\{gnus-server-mode-map}"
146 (interactive) 134 (interactive)
147 (when (gnus-visual-p 'server-menu 'menu) 135 (when (and menu-bar-mode
136 (gnus-visual-p 'server-menu 'menu))
148 (gnus-server-make-menu-bar)) 137 (gnus-server-make-menu-bar))
149 (kill-all-local-variables) 138 (kill-all-local-variables)
150 (gnus-simplify-mode-line) 139 (gnus-simplify-mode-line)
151 (setq major-mode 'gnus-server-mode) 140 (setq major-mode 'gnus-server-mode)
152 (setq mode-name "Server") 141 (setq mode-name "Server")
153 (gnus-set-default-directory) 142 ; (gnus-group-set-mode-line)
154 (setq mode-line-process nil) 143 (setq mode-line-process nil)
155 (use-local-map gnus-server-mode-map) 144 (use-local-map gnus-server-mode-map)
156 (buffer-disable-undo (current-buffer)) 145 (buffer-disable-undo (current-buffer))
157 (setq truncate-lines t) 146 (setq truncate-lines t)
158 (setq buffer-read-only t) 147 (setq buffer-read-only t)
187 "Initialize the server buffer." 176 "Initialize the server buffer."
188 (unless (get-buffer gnus-server-buffer) 177 (unless (get-buffer gnus-server-buffer)
189 (save-excursion 178 (save-excursion
190 (set-buffer (get-buffer-create gnus-server-buffer)) 179 (set-buffer (get-buffer-create gnus-server-buffer))
191 (gnus-server-mode) 180 (gnus-server-mode)
192 (when gnus-carpal 181 (when gnus-carpal
193 (gnus-carpal-setup-buffer 'server))))) 182 (gnus-carpal-setup-buffer 'server)))))
194 183
195 (defun gnus-server-prepare () 184 (defun gnus-server-prepare ()
196 (setq gnus-server-mode-line-format-spec 185 (setq gnus-server-mode-line-format-spec
197 (gnus-parse-format gnus-server-mode-line-format 186 (gnus-parse-format gnus-server-mode-line-format
198 gnus-server-mode-line-format-alist)) 187 gnus-server-mode-line-format-alist))
199 (setq gnus-server-line-format-spec 188 (setq gnus-server-line-format-spec
200 (gnus-parse-format gnus-server-line-format 189 (gnus-parse-format gnus-server-line-format
201 gnus-server-line-format-alist t)) 190 gnus-server-line-format-alist t))
202 (let ((alist gnus-server-alist) 191 (let ((alist gnus-server-alist)
203 (buffer-read-only nil) 192 (buffer-read-only nil)
204 (opened gnus-opened-servers) 193 (opened gnus-opened-servers)
205 done server op-ser) 194 done server op-ser)
206 (erase-buffer) 195 (erase-buffer)
207 (setq gnus-inserted-opened-servers nil) 196 (setq gnus-inserted-opened-servers nil)
208 ;; First we do the real list of servers. 197 ;; First we do the real list of servers.
209 (while alist 198 (while alist
210 (unless (member (cdar alist) done) 199 (push (cdr (setq server (pop alist))) done)
211 (push (cdar alist) done) 200 (when (and server (car server) (cdr server))
212 (cdr (setq server (pop alist))) 201 (gnus-server-insert-server-line (car server) (cdr server))))
213 (when (and server (car server) (cdr server))
214 (gnus-server-insert-server-line (car server) (cdr server))))
215 (when (member (cdar alist) done)
216 (pop alist)))
217 ;; Then we insert the list of servers that have been opened in 202 ;; Then we insert the list of servers that have been opened in
218 ;; this session. 203 ;; this session.
219 (while opened 204 (while opened
220 (unless (member (caar opened) done) 205 (unless (member (caar opened) done)
221 (push (caar opened) done) 206 (gnus-server-insert-server-line
222 (gnus-server-insert-server-line
223 (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened)))) 207 (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened))))
224 (caar opened)) 208 (caar opened))
225 (push (list op-ser (caar opened)) gnus-inserted-opened-servers)) 209 (push (list op-ser (caar opened)) gnus-inserted-opened-servers))
226 (setq opened (cdr opened)))) 210 (setq opened (cdr opened))))
227 (goto-char (point-min)) 211 (goto-char (point-min))
241 (let* ((buffer-read-only nil) 225 (let* ((buffer-read-only nil)
242 (entry (assoc server gnus-server-alist)) 226 (entry (assoc server gnus-server-alist))
243 (oentry (assoc (gnus-server-to-method server) 227 (oentry (assoc (gnus-server-to-method server)
244 gnus-opened-servers))) 228 gnus-opened-servers)))
245 (when entry 229 (when entry
246 (gnus-dribble-enter 230 (gnus-dribble-enter
247 (concat "(gnus-server-set-info \"" server "\" '" 231 (concat "(gnus-server-set-info \"" server "\" '"
248 (prin1-to-string (cdr entry)) ")\n"))) 232 (prin1-to-string (cdr entry)) ")")))
249 (when (or entry oentry) 233 (when (or entry oentry)
250 ;; Buffer may be narrowed. 234 ;; Buffer may be narrowed.
251 (save-restriction 235 (save-restriction
252 (widen) 236 (widen)
253 (when (gnus-server-goto-server server) 237 (when (gnus-server-goto-server server)
254 (gnus-delete-line)) 238 (gnus-delete-line))
255 (if entry 239 (if entry
256 (gnus-server-insert-server-line (car entry) (cdr entry)) 240 (gnus-server-insert-server-line (car entry) (cdr entry))
257 (gnus-server-insert-server-line 241 (gnus-server-insert-server-line
258 (format "%s:%s" (caar oentry) (nth 1 (car oentry))) 242 (format "%s:%s" (caar oentry) (nth 1 (car oentry)))
259 (car oentry))) 243 (car oentry)))
260 (gnus-server-position-point)))))) 244 (gnus-server-position-point))))))
261 245
262 (defun gnus-server-set-info (server info) 246 (defun gnus-server-set-info (server info)
263 ;; Enter a select method into the virtual server alist. 247 ;; Enter a select method into the virtual server alist.
264 (when (and server info) 248 (when (and server info)
265 (gnus-dribble-enter 249 (gnus-dribble-enter
266 (concat "(gnus-server-set-info \"" server "\" '" 250 (concat "(gnus-server-set-info \"" server "\" '"
267 (prin1-to-string info) ")")) 251 (prin1-to-string info) ")"))
268 (let* ((server (nth 1 info)) 252 (let* ((server (nth 1 info))
269 (entry (assoc server gnus-server-alist))) 253 (entry (assoc server gnus-server-alist)))
270 (if entry (setcdr entry info) 254 (if entry (setcdr entry info)
282 (unless (assoc server gnus-server-alist) 266 (unless (assoc server gnus-server-alist)
283 (error "Read-only server %s" server)) 267 (error "Read-only server %s" server))
284 (gnus-dribble-enter "") 268 (gnus-dribble-enter "")
285 (let ((buffer-read-only nil)) 269 (let ((buffer-read-only nil))
286 (gnus-delete-line)) 270 (gnus-delete-line))
287 (push (assoc server gnus-server-alist) gnus-server-killed-servers) 271 (setq gnus-server-killed-servers
272 (cons (assoc server gnus-server-alist) gnus-server-killed-servers))
288 (setq gnus-server-alist (delq (car gnus-server-killed-servers) 273 (setq gnus-server-alist (delq (car gnus-server-killed-servers)
289 gnus-server-alist)) 274 gnus-server-alist))
290 (gnus-server-position-point)) 275 (gnus-server-position-point))
291 276
292 (defun gnus-server-yank-server () 277 (defun gnus-server-yank-server ()
293 "Yank the previously killed server." 278 "Yank the previously killed server."
294 (interactive) 279 (interactive)
295 (unless gnus-server-killed-servers 280 (or gnus-server-killed-servers
296 (error "No killed servers to be yanked")) 281 (error "No killed servers to be yanked"))
297 (let ((alist gnus-server-alist) 282 (let ((alist gnus-server-alist)
298 (server (gnus-server-server-name)) 283 (server (gnus-server-server-name))
299 (killed (car gnus-server-killed-servers))) 284 (killed (car gnus-server-killed-servers)))
300 (if (not server) 285 (if (not server)
301 (setq gnus-server-alist (nconc gnus-server-alist (list killed))) 286 (setq gnus-server-alist (nconc gnus-server-alist (list killed)))
302 (if (string= server (caar gnus-server-alist)) 287 (if (string= server (caar gnus-server-alist))
303 (push killed gnus-server-alist) 288 (setq gnus-server-alist (cons killed gnus-server-alist))
304 (while (and (cdr alist) 289 (while (and (cdr alist)
305 (not (string= server (caadr alist)))) 290 (not (string= server (caadr alist))))
306 (setq alist (cdr alist))) 291 (setq alist (cdr alist)))
307 (if alist 292 (if alist
308 (setcdr alist (cons killed (cdr alist))) 293 (setcdr alist (cons killed (cdr alist)))
342 327
343 (defun gnus-server-open-server (server) 328 (defun gnus-server-open-server (server)
344 "Force an open of SERVER." 329 "Force an open of SERVER."
345 (interactive (list (gnus-server-server-name))) 330 (interactive (list (gnus-server-server-name)))
346 (let ((method (gnus-server-to-method server))) 331 (let ((method (gnus-server-to-method server)))
347 (unless method 332 (or method (error "No such server: %s" server))
348 (error "No such server: %s" server))
349 (gnus-server-set-status method 'ok) 333 (gnus-server-set-status method 'ok)
350 (prog1 334 (prog1
351 (or (gnus-open-server method) 335 (or (gnus-open-server method)
352 (progn (message "Couldn't open %s" server) nil)) 336 (progn (message "Couldn't open %s" server) nil))
353 (gnus-server-update-server server) 337 (gnus-server-update-server server)
354 (gnus-server-position-point)))) 338 (gnus-server-position-point))))
355 339
356 (defun gnus-server-open-all-servers ()
357 "Open all servers."
358 (interactive)
359 (let ((servers gnus-inserted-opened-servers))
360 (while servers
361 (gnus-server-open-server (car (pop servers))))))
362
363 (defun gnus-server-close-server (server) 340 (defun gnus-server-close-server (server)
364 "Close SERVER." 341 "Close SERVER."
365 (interactive (list (gnus-server-server-name))) 342 (interactive (list (gnus-server-server-name)))
366 (let ((method (gnus-server-to-method server))) 343 (let ((method (gnus-server-to-method server)))
367 (unless method 344 (or method (error "No such server: %s" server))
368 (error "No such server: %s" server))
369 (gnus-server-set-status method 'closed) 345 (gnus-server-set-status method 'closed)
370 (prog1 346 (prog1
371 (gnus-close-server method) 347 (gnus-close-server method)
372 (gnus-server-update-server server) 348 (gnus-server-update-server server)
373 (gnus-server-position-point)))) 349 (gnus-server-position-point))))
374 350
375 (defun gnus-server-close-all-servers ()
376 "Close all servers."
377 (interactive)
378 (let ((servers gnus-inserted-opened-servers))
379 (while servers
380 (gnus-server-close-server (car (pop servers))))))
381
382 (defun gnus-server-deny-server (server) 351 (defun gnus-server-deny-server (server)
383 "Make sure SERVER will never be attempted opened." 352 "Make sure SERVER will never be attempted opened."
384 (interactive (list (gnus-server-server-name))) 353 (interactive (list (gnus-server-server-name)))
385 (let ((method (gnus-server-to-method server))) 354 (let ((method (gnus-server-to-method server)))
386 (unless method 355 (or method (error "No such server: %s" server))
387 (error "No such server: %s" server))
388 (gnus-server-set-status method 'denied)) 356 (gnus-server-set-status method 'denied))
389 (gnus-server-update-server server) 357 (gnus-server-update-server server)
390 (gnus-server-position-point) 358 (gnus-server-position-point)
391 t) 359 t)
392 360
404 (interactive 372 (interactive
405 (list 373 (list
406 (or (gnus-server-server-name) 374 (or (gnus-server-server-name)
407 (error "No server on the current line")) 375 (error "No server on the current line"))
408 (read-string "Copy to: "))) 376 (read-string "Copy to: ")))
409 (unless from 377 (or from (error "No server on current line"))
410 (error "No server on current line")) 378 (or (and to (not (string= to ""))) (error "No name to copy to"))
411 (unless (and to (not (string= to ""))) 379 (and (assoc to gnus-server-alist) (error "%s already exists" to))
412 (error "No name to copy to")) 380 (or (assoc from gnus-server-alist)
413 (when (assoc to gnus-server-alist) 381 (error "%s: no such server" from))
414 (error "%s already exists" to)) 382 (let ((to-entry (gnus-copy-sequence (assoc from gnus-server-alist))))
415 (unless (gnus-server-to-method from)
416 (error "%s: no such server" from))
417 (let ((to-entry (cons from (gnus-copy-sequence
418 (gnus-server-to-method from)))))
419 (setcar to-entry to) 383 (setcar to-entry to)
420 (setcar (nthcdr 2 to-entry) to) 384 (setcar (nthcdr 2 to-entry) to)
421 (push to-entry gnus-server-killed-servers) 385 (setq gnus-server-killed-servers
386 (cons to-entry gnus-server-killed-servers))
422 (gnus-server-yank-server))) 387 (gnus-server-yank-server)))
423 388
424 (defun gnus-server-add-server (how where) 389 (defun gnus-server-add-server (how where)
425 (interactive 390 (interactive
426 (list (intern (completing-read "Server method: " 391 (list (intern (completing-read "Server method: "
427 gnus-valid-select-methods nil t)) 392 gnus-valid-select-methods nil t))
428 (read-string "Server name: "))) 393 (read-string "Server name: ")))
429 (when (assq where gnus-server-alist) 394 (setq gnus-server-killed-servers
430 (error "Server with that name already defined")) 395 (cons (list where how where) gnus-server-killed-servers))
431 (push (list where how where) gnus-server-killed-servers)
432 (gnus-server-yank-server)) 396 (gnus-server-yank-server))
433 397
434 (defun gnus-server-goto-server (server) 398 (defun gnus-server-goto-server (server)
435 "Jump to a server line." 399 "Jump to a server line."
436 (interactive 400 (interactive
437 (list (completing-read "Goto server: " gnus-server-alist nil t))) 401 (list (completing-read "Goto server: " gnus-server-alist nil t)))
438 (let ((to (text-property-any (point-min) (point-max) 402 (let ((to (text-property-any (point-min) (point-max)
439 'gnus-server (intern server)))) 403 'gnus-server (intern server))))
440 (when to 404 (and to
441 (goto-char to) 405 (progn
442 (gnus-server-position-point)))) 406 (goto-char to)
407 (gnus-server-position-point)))))
443 408
444 (defun gnus-server-edit-server (server) 409 (defun gnus-server-edit-server (server)
445 "Edit the server on the current line." 410 "Edit the server on the current line."
446 (interactive (list (gnus-server-server-name))) 411 (interactive (list (gnus-server-server-name)))
447 (unless server 412 (unless server
448 (error "No server on current line")) 413 (error "No server on current line"))
449 (unless (assoc server gnus-server-alist) 414 (unless (assoc server gnus-server-alist)
450 (error "This server can't be edited")) 415 (error "This server can't be edited"))
451 (let ((info (cdr (assoc server gnus-server-alist)))) 416 (let ((winconf (current-window-configuration))
417 (info (cdr (assoc server gnus-server-alist))))
452 (gnus-close-server info) 418 (gnus-close-server info)
453 (gnus-edit-form 419 (get-buffer-create gnus-server-edit-buffer)
454 info "Editing the server." 420 (gnus-configure-windows 'edit-server)
455 `(lambda (form) 421 (gnus-add-current-to-buffer-list)
456 (gnus-server-set-info ,server form) 422 (emacs-lisp-mode)
457 (gnus-server-list-servers) 423 (make-local-variable 'gnus-prev-winconf)
458 (gnus-server-position-point))))) 424 (setq gnus-prev-winconf winconf)
459 425 (use-local-map (copy-keymap (current-local-map)))
460 (defun gnus-server-scan-server (server) 426 (let ((done-func '(lambda ()
461 "Request a scan from the current server." 427 "Exit editing mode and update the information."
462 (interactive (list (gnus-server-server-name))) 428 (interactive)
463 (gnus-message 3 "Scanning %s...done" server) 429 (gnus-server-edit-server-done 'group))))
464 (gnus-request-scan nil (gnus-server-to-method server)) 430 (setcar (cdr (nth 4 done-func)) server)
465 (gnus-message 3 "Scanning %s...done" server)) 431 (local-set-key "\C-c\C-c" done-func))
432 (erase-buffer)
433 (insert ";; Type `C-c C-c' after you have edited the server.\n\n")
434 (insert (pp-to-string info))))
435
436 (defun gnus-server-edit-server-done (server)
437 (interactive)
438 (set-buffer (get-buffer-create gnus-server-edit-buffer))
439 (goto-char (point-min))
440 (let ((form (read (current-buffer)))
441 (winconf gnus-prev-winconf))
442 (gnus-server-set-info server form)
443 (kill-buffer (current-buffer))
444 (and winconf (set-window-configuration winconf))
445 (set-buffer gnus-server-buffer)
446 (gnus-server-update-server server)
447 (gnus-server-list-servers)
448 (gnus-server-position-point)))
466 449
467 (defun gnus-server-read-server (server) 450 (defun gnus-server-read-server (server)
468 "Browse a server." 451 "Browse a server."
469 (interactive (list (gnus-server-server-name))) 452 (interactive (list (gnus-server-server-name)))
470 (let ((buf (current-buffer))) 453 (let ((buf (current-buffer)))
472 (gnus-browse-foreign-server (gnus-server-to-method server) buf) 455 (gnus-browse-foreign-server (gnus-server-to-method server) buf)
473 (save-excursion 456 (save-excursion
474 (set-buffer buf) 457 (set-buffer buf)
475 (gnus-server-update-server (gnus-server-server-name)) 458 (gnus-server-update-server (gnus-server-server-name))
476 (gnus-server-position-point))))) 459 (gnus-server-position-point)))))
477 460
478 (defun gnus-server-pick-server (e) 461 (defun gnus-server-pick-server (e)
479 (interactive "e") 462 (interactive "e")
480 (mouse-set-point e) 463 (mouse-set-point e)
481 (gnus-server-read-server (gnus-server-server-name))) 464 (gnus-server-read-server (gnus-server-server-name)))
482 465
514 "q" gnus-browse-exit 497 "q" gnus-browse-exit
515 "Q" gnus-browse-exit 498 "Q" gnus-browse-exit
516 "\C-c\C-c" gnus-browse-exit 499 "\C-c\C-c" gnus-browse-exit
517 "?" gnus-browse-describe-briefly 500 "?" gnus-browse-describe-briefly
518 501
519 "\C-c\C-i" gnus-info-find-node 502 "\C-c\C-i" gnus-info-find-node))
520 "\C-c\C-b" gnus-bug))
521 503
522 (defun gnus-browse-make-menu-bar () 504 (defun gnus-browse-make-menu-bar ()
523 (gnus-turn-off-edit-menu 'browse) 505 (gnus-visual-turn-off-edit-menu 'browse)
524 (unless (boundp 'gnus-browse-menu) 506 (or
525 (easy-menu-define 507 (boundp 'gnus-browse-menu)
526 gnus-browse-menu gnus-browse-mode-map "" 508 (progn
527 '("Browse" 509 (easy-menu-define
528 ["Subscribe" gnus-browse-unsubscribe-current-group t] 510 gnus-browse-menu gnus-browse-mode-map ""
529 ["Read" gnus-browse-read-group t] 511 '("Browse"
530 ["Select" gnus-browse-read-group t] 512 ["Subscribe" gnus-browse-unsubscribe-current-group t]
531 ["Next" gnus-browse-next-group t] 513 ["Read" gnus-browse-read-group t]
532 ["Prev" gnus-browse-next-group t] 514 ["Select" gnus-browse-read-group t]
533 ["Exit" gnus-browse-exit t])) 515 ["Next" gnus-browse-next-group t]
534 (run-hooks 'gnus-browse-menu-hook))) 516 ["Prev" gnus-browse-next-group t]
517 ["Exit" gnus-browse-exit t]
518 ))
519 (run-hooks 'gnus-browse-menu-hook))))
535 520
536 (defvar gnus-browse-current-method nil) 521 (defvar gnus-browse-current-method nil)
537 (defvar gnus-browse-return-buffer nil) 522 (defvar gnus-browse-return-buffer nil)
538 523
539 (defvar gnus-browse-buffer "*Gnus Browse Server*") 524 (defvar gnus-browse-buffer "*Gnus Browse Server*")
540 525
541 (defun gnus-browse-foreign-server (method &optional return-buffer) 526 (defun gnus-browse-foreign-server (method &optional return-buffer)
542 "Browse the server METHOD." 527 "Browse the server METHOD."
543 (setq gnus-browse-current-method method) 528 (setq gnus-browse-current-method method)
544 (setq gnus-browse-return-buffer return-buffer) 529 (setq gnus-browse-return-buffer return-buffer)
545 (when (stringp method)
546 (setq method (gnus-server-to-method method)))
547 (let ((gnus-select-method method) 530 (let ((gnus-select-method method)
548 groups group) 531 groups group)
549 (gnus-message 5 "Connecting to %s..." (nth 1 method)) 532 (gnus-message 5 "Connecting to %s..." (nth 1 method))
550 (cond 533 (cond
551 ((not (gnus-check-server method)) 534 ((not (gnus-check-server method))
552 (gnus-message 535 (gnus-message
553 1 "Unable to contact server: %s" (gnus-status-message method)) 536 1 "Unable to contact server: %s" (gnus-status-message method))
554 nil) 537 nil)
555 ((not 538 ((not (gnus-request-list method))
556 (prog2
557 (gnus-message 6 "Reading active file...")
558 (gnus-request-list method)
559 (gnus-message 6 "Reading active file...done")))
560 (gnus-message 539 (gnus-message
561 1 "Couldn't request list: %s" (gnus-status-message method)) 540 1 "Couldn't request list: %s" (gnus-status-message method))
562 nil) 541 nil)
563 (t 542 (t
564 (get-buffer-create gnus-browse-buffer) 543 (get-buffer-create gnus-browse-buffer)
565 (gnus-add-current-to-buffer-list) 544 (gnus-add-current-to-buffer-list)
566 (when gnus-carpal 545 (and gnus-carpal (gnus-carpal-setup-buffer 'browse))
567 (gnus-carpal-setup-buffer 'browse))
568 (gnus-configure-windows 'browse) 546 (gnus-configure-windows 'browse)
569 (buffer-disable-undo (current-buffer)) 547 (buffer-disable-undo (current-buffer))
570 (let ((buffer-read-only nil)) 548 (let ((buffer-read-only nil))
571 (erase-buffer)) 549 (erase-buffer))
572 (gnus-browse-mode) 550 (gnus-browse-mode)
576 "Gnus: %%b {%s:%s}" (car method) (cadr method)))) 554 "Gnus: %%b {%s:%s}" (car method) (cadr method))))
577 (save-excursion 555 (save-excursion
578 (set-buffer nntp-server-buffer) 556 (set-buffer nntp-server-buffer)
579 (let ((cur (current-buffer))) 557 (let ((cur (current-buffer)))
580 (goto-char (point-min)) 558 (goto-char (point-min))
581 (unless (string= gnus-ignored-newsgroups "") 559 (or (string= gnus-ignored-newsgroups "")
582 (delete-matching-lines gnus-ignored-newsgroups)) 560 (delete-matching-lines gnus-ignored-newsgroups))
583 (while (re-search-forward 561 (while (re-search-forward
584 "\\(^[^ \t]+\\)[ \t]+[0-9]+[ \t]+[0-9]+" nil t) 562 "\\(^[^ \t]+\\)[ \t]+[0-9]+[ \t]+[0-9]+" nil t)
585 (goto-char (match-end 1)) 563 (goto-char (match-end 1))
586 (push (cons (match-string 1) 564 (setq groups (cons (cons (match-string 1)
587 (max 0 (- (1+ (read cur)) (read cur)))) 565 (max 0 (- (1+ (read cur)) (read cur))))
588 groups)))) 566 groups)))))
589 (setq groups (sort groups 567 (setq groups (sort groups
590 (lambda (l1 l2) 568 (lambda (l1 l2)
591 (string< (car l1) (car l2))))) 569 (string< (car l1) (car l2)))))
592 (let ((buffer-read-only nil)) 570 (let ((buffer-read-only nil))
593 (while groups 571 (while groups
616 2) `\\[gnus-browse-read-group]' to read a group ephemerally. 594 2) `\\[gnus-browse-read-group]' to read a group ephemerally.
617 595
618 3) `\\[gnus-browse-exit]' to return to the group buffer." 596 3) `\\[gnus-browse-exit]' to return to the group buffer."
619 (interactive) 597 (interactive)
620 (kill-all-local-variables) 598 (kill-all-local-variables)
621 (when (gnus-visual-p 'browse-menu 'menu) 599 (when (and menu-bar-mode
600 (gnus-visual-p 'browse-menu 'menu))
622 (gnus-browse-make-menu-bar)) 601 (gnus-browse-make-menu-bar))
623 (gnus-simplify-mode-line) 602 (gnus-simplify-mode-line)
624 (setq major-mode 'gnus-browse-mode) 603 (setq major-mode 'gnus-browse-mode)
625 (setq mode-name "Browse Server") 604 (setq mode-name "Browse Server")
626 (setq mode-line-process nil) 605 (setq mode-line-process nil)
627 (use-local-map gnus-browse-mode-map) 606 (use-local-map gnus-browse-mode-map)
628 (buffer-disable-undo (current-buffer)) 607 (buffer-disable-undo (current-buffer))
629 (setq truncate-lines t) 608 (setq truncate-lines t)
630 (gnus-set-default-directory)
631 (setq buffer-read-only t) 609 (setq buffer-read-only t)
632 (run-hooks 'gnus-browse-mode-hook)) 610 (run-hooks 'gnus-browse-mode-hook))
633 611
634 (defun gnus-browse-read-group (&optional no-article) 612 (defun gnus-browse-read-group (&optional no-article)
635 "Enter the group at the current line." 613 "Enter the group at the current line."
636 (interactive) 614 (interactive)
637 (let ((group (gnus-group-real-name (gnus-browse-group-name)))) 615 (let ((group (gnus-browse-group-name)))
638 (unless (gnus-group-read-ephemeral-group 616 (or (gnus-group-read-ephemeral-group
639 group gnus-browse-current-method nil 617 group gnus-browse-current-method nil
640 (cons (current-buffer) 'browse)) 618 (cons (current-buffer) 'browse))
641 (error "Couldn't enter %s" group)))) 619 (error "Couldn't enter %s" group))))
642 620
643 (defun gnus-browse-select-group () 621 (defun gnus-browse-select-group ()
644 "Select the current group." 622 "Select the current group."
645 (interactive) 623 (interactive)
646 (gnus-browse-read-group 'no)) 624 (gnus-browse-read-group 'no))
668 (not (eobp)) 646 (not (eobp))
669 (gnus-browse-unsubscribe-group) 647 (gnus-browse-unsubscribe-group)
670 (zerop (gnus-browse-next-group ward))) 648 (zerop (gnus-browse-next-group ward)))
671 (decf arg)) 649 (decf arg))
672 (gnus-group-position-point) 650 (gnus-group-position-point)
673 (when (/= 0 arg) 651 (if (/= 0 arg) (gnus-message 7 "No more newsgroups"))
674 (gnus-message 7 "No more newsgroups"))
675 arg)) 652 arg))
676 653
677 (defun gnus-browse-group-name () 654 (defun gnus-browse-group-name ()
678 (save-excursion 655 (save-excursion
679 (beginning-of-line) 656 (beginning-of-line)
686 (buffer-read-only nil) 663 (buffer-read-only nil)
687 group) 664 group)
688 (save-excursion 665 (save-excursion
689 (beginning-of-line) 666 (beginning-of-line)
690 ;; If this group it killed, then we want to subscribe it. 667 ;; If this group it killed, then we want to subscribe it.
691 (when (= (following-char) ?K) 668 (if (= (following-char) ?K) (setq sub t))
692 (setq sub t))
693 (setq group (gnus-browse-group-name)) 669 (setq group (gnus-browse-group-name))
694 ;; Make sure the group has been properly removed before we
695 ;; subscribe to it.
696 (gnus-kill-ephemeral-group group)
697 (delete-char 1) 670 (delete-char 1)
698 (if sub 671 (if sub
699 (progn 672 (progn
700 (gnus-group-change-level 673 (gnus-group-change-level
701 (list t group gnus-level-default-subscribed 674 (list t group gnus-level-default-subscribed
728 "Give a one line description of the group mode commands." 701 "Give a one line description of the group mode commands."
729 (interactive) 702 (interactive)
730 (gnus-message 6 703 (gnus-message 6
731 (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"))) 704 (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")))
732 705
733 (defun gnus-server-regenerate-server ()
734 "Issue a command to the server to regenerate all its data structures."
735 (interactive)
736 (let ((server (gnus-server-server-name)))
737 (unless server
738 (error "No server on the current line"))
739 (if (not (gnus-check-backend-function
740 'request-regenerate (car (gnus-server-to-method server))))
741 (error "This backend doesn't support regeneration")
742 (gnus-message 5 "Requesting regeneration of %s..." server)
743 (if (gnus-request-regenerate server)
744 (gnus-message 5 "Requesting regeneration of %s...done" server)
745 (gnus-message 5 "Couldn't regenerate %s" server)))))
746
747 (provide 'gnus-srvr) 706 (provide 'gnus-srvr)
748 707
749 ;;; gnus-srvr.el ends here. 708 ;;; gnus-srvr.el ends here.