Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-srvr.el @ 16:0293115a14e9 r19-15b91

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