Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-srvr.el @ 98:0d2f883870bc r20-1b1

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