cgit.sxemacs.org Git - gnus/blob - lisp/gnus-srvr.el

   1 ;;; gnus-srvr.el --- virtual server support for Gnus
   2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (eval-when-compile (require 'cl))
  30
  31 (require 'gnus)
  32 (require 'gnus-spec)
  33 (require 'gnus-group)
  34 (require 'gnus-int)
  35 (require 'gnus-range)
  36
  37 (defcustom gnus-server-mode-hook nil
  38   "Hook run in `gnus-server-mode' buffers."
  39   :group 'gnus-server
  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"
  48   "Format of server lines.
  49 It works along the same lines as a normal formatting string,
  50 with some simple extensions.
  51
  52 The following specs are understood:
  53
  54 %h backend
  55 %n name
  56 %w address
  57 %s status
  58 %a agent covered
  59
  60 General format specifiers can also be used.
  61 See (gnus)Formatting Variables."
  62   :link '(custom-manual "(gnus)Formatting Variables")
  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 'string)
  76
  77 ;;; Internal variables.
  78
  79 (defvar gnus-inserted-opened-servers nil)
  80
  81 (defvar gnus-server-line-format-alist
  82   `((?h gnus-tmp-how ?s)
  83     (?n gnus-tmp-name ?s)
  84     (?w gnus-tmp-where ?s)
  85     (?s gnus-tmp-status ?s)
  86     (?a gnus-tmp-agent ?s)))
  87
  88 (defvar gnus-server-mode-line-format-alist
  89   `((?S gnus-tmp-news-server ?s)
  90     (?M gnus-tmp-news-method ?s)
  91     (?u gnus-tmp-user-defined ?s)))
  92
  93 (defvar gnus-server-line-format-spec nil)
  94 (defvar gnus-server-mode-line-format-spec nil)
  95 (defvar gnus-server-killed-servers nil)
  96
  97 (defvar gnus-server-mode-map)
  98
  99 (defvar gnus-server-menu-hook nil
 100   "*Hook run after the creation of the server mode menu.")
 101
 102 (defun gnus-server-make-menu-bar ()
 103   (gnus-turn-off-edit-menu 'server)
 104   (unless (boundp 'gnus-server-server-menu)
 105     (easy-menu-define
 106      gnus-server-server-menu gnus-server-mode-map ""
 107      '("Server"
 108        ["Add" gnus-server-add-server t]
 109        ["Browse" gnus-server-read-server t]
 110        ["Scan" gnus-server-scan-server t]
 111        ["List" gnus-server-list-servers t]
 112        ["Kill" gnus-server-kill-server t]
 113        ["Yank" gnus-server-yank-server t]
 114        ["Copy" gnus-server-copy-server t]
 115        ["Edit" gnus-server-edit-server t]
 116        ["Regenerate" gnus-server-regenerate-server t]
 117        ["Exit" gnus-server-exit t]))
 118
 119     (easy-menu-define
 120      gnus-server-connections-menu gnus-server-mode-map ""
 121      '("Connections"
 122        ["Open" gnus-server-open-server t]
 123        ["Close" gnus-server-close-server t]
 124        ["Deny" gnus-server-deny-server t]
 125        "---"
 126        ["Open All" gnus-server-open-all-servers t]
 127        ["Close All" gnus-server-close-all-servers t]
 128        ["Reset All" gnus-server-remove-denials t]))
 129
 130     (gnus-run-hooks 'gnus-server-menu-hook)))
 131
 132 (defvar gnus-server-mode-map nil)
 133 (put 'gnus-server-mode 'mode-class 'special)
 134
 135 (unless gnus-server-mode-map
 136   (setq gnus-server-mode-map (make-sparse-keymap))
 137   (suppress-keymap gnus-server-mode-map)
 138
 139   (gnus-define-keys gnus-server-mode-map
 140     " " gnus-server-read-server-in-server-buffer
 141     "\r" gnus-server-read-server
 142     gnus-mouse-2 gnus-server-pick-server
 143     "q" gnus-server-exit
 144     "l" gnus-server-list-servers
 145     "k" gnus-server-kill-server
 146     "y" gnus-server-yank-server
 147     "c" gnus-server-copy-server
 148     "a" gnus-server-add-server
 149     "e" gnus-server-edit-server
 150     "s" gnus-server-scan-server
 151
 152     "O" gnus-server-open-server
 153     "\M-o" gnus-server-open-all-servers
 154     "C" gnus-server-close-server
 155     "\M-c" gnus-server-close-all-servers
 156     "D" gnus-server-deny-server
 157     "R" gnus-server-remove-denials
 158
 159     "n" next-line
 160     "p" previous-line
 161
 162     "g" gnus-server-regenerate-server
 163
 164     "\C-c\C-i" gnus-info-find-node
 165     "\C-c\C-b" gnus-bug))
 166
 167 (defface gnus-server-agent-face
 168   '((((class color) (background light)) (:foreground "PaleTurquoise" :bold t))
 169     (((class color) (background dark)) (:foreground "PaleTurquoise" :bold t))
 170     (t (:bold t)))
 171   "Face used for displaying AGENTIZED servers"
 172   :group 'gnus-server-visual)
 173
 174 (defface gnus-server-opened-face
 175   '((((class color) (background light)) (:foreground "Green3" :bold t))
 176     (((class color) (background dark)) (:foreground "Green1" :bold t))
 177     (t (:bold t)))
 178   "Face used for displaying OPENED servers"
 179   :group 'gnus-server-visual)
 180
 181 (defface gnus-server-closed-face
 182   '((((class color) (background light)) (:foreground "Steel Blue" :italic t))
 183     (((class color) (background dark))
 184      (:foreground "Light Steel Blue" :italic t))
 185     (t (:italic t)))
 186   "Face used for displaying CLOSED servers"
 187   :group 'gnus-server-visual)
 188
 189 (defface gnus-server-denied-face
 190   '((((class color) (background light)) (:foreground "Red" :bold t))
 191     (((class color) (background dark)) (:foreground "Pink" :bold t))
 192     (t (:inverse-video t :bold t)))
 193   "Face used for displaying DENIED servers"
 194   :group 'gnus-server-visual)
 195
 196 (defcustom gnus-server-agent-face 'gnus-server-agent-face
 197   "Face name to use on AGENTIZED servers."
 198   :group 'gnus-server-visual
 199   :type 'face)
 200
 201 (defcustom gnus-server-opened-face 'gnus-server-opened-face
 202   "Face name to use on OPENED servers."
 203   :group 'gnus-server-visual
 204   :type 'face)
 205
 206 (defcustom gnus-server-closed-face 'gnus-server-closed-face
 207   "Face name to use on CLOSED servers."
 208   :group 'gnus-server-visual
 209   :type 'face)
 210
 211 (defcustom gnus-server-denied-face 'gnus-server-denied-face
 212   "Face name to use on DENIED servers."
 213   :group 'gnus-server-visual
 214   :type 'face)
 215
 216 (defvar gnus-server-font-lock-keywords
 217   (list
 218    '("(\\(agent\\))" 1 gnus-server-agent-face)
 219    '("(\\(opened\\))" 1 gnus-server-opened-face)
 220    '("(\\(closed\\))" 1 gnus-server-closed-face)
 221    '("(\\(denied\\))" 1 gnus-server-denied-face)))
 222
 223 (defun gnus-server-mode ()
 224   "Major mode for listing and editing servers.
 225
 226 All normal editing commands are switched off.
 227 \\<gnus-server-mode-map>
 228 For more in-depth information on this mode, read the manual
 229 \(`\\[gnus-info-find-node]').
 230
 231 The following commands are available:
 232
 233 \\{gnus-server-mode-map}"
 234   (interactive)
 235   (when (gnus-visual-p 'server-menu 'menu)
 236     (gnus-server-make-menu-bar))
 237   (kill-all-local-variables)
 238   (gnus-simplify-mode-line)
 239   (setq major-mode 'gnus-server-mode)
 240   (setq mode-name "Server")
 241   (gnus-set-default-directory)
 242   (setq mode-line-process nil)
 243   (use-local-map gnus-server-mode-map)
 244   (buffer-disable-undo)
 245   (setq truncate-lines t)
 246   (setq buffer-read-only t)
 247   (if (featurep 'xemacs)
 248       (put 'gnus-server-mode 'font-lock-defaults '(gnus-server-font-lock-keywords t))
 249     (set (make-local-variable 'font-lock-defaults)
 250          '(gnus-server-font-lock-keywords t)))
 251   (gnus-run-hooks 'gnus-server-mode-hook))
 252
 253 (defun gnus-server-insert-server-line (gnus-tmp-name method)
 254   (let* ((gnus-tmp-how (car method))
 255          (gnus-tmp-where (nth 1 method))
 256          (elem (assoc method gnus-opened-servers))
 257          (gnus-tmp-status
 258           (if (eq (nth 1 elem) 'denied)
 259               "(denied)"
 260             (condition-case nil
 261                 (if (or (gnus-server-opened method)
 262                         (eq (nth 1 elem) 'ok))
 263                     "(opened)"
 264                   "(closed)")
 265               ((error) "(error)"))))
 266          (gnus-tmp-agent (if (and gnus-agent
 267                                   (member method
 268                                           gnus-agent-covered-methods))
 269                              " (agent)"
 270                            "")))
 271     (beginning-of-line)
 272     (gnus-add-text-properties
 273      (point)
 274      (prog1 (1+ (point))
 275        ;; Insert the text.
 276        (eval gnus-server-line-format-spec))
 277      (list 'gnus-server (intern gnus-tmp-name)))))
 278
 279 (defun gnus-enter-server-buffer ()
 280   "Set up the server buffer."
 281   (gnus-server-setup-buffer)
 282   (gnus-configure-windows 'server)
 283   (gnus-server-prepare))
 284
 285 (defun gnus-server-setup-buffer ()
 286   "Initialize the server buffer."
 287   (unless (get-buffer gnus-server-buffer)
 288     (save-excursion
 289       (set-buffer (gnus-get-buffer-create gnus-server-buffer))
 290       (gnus-server-mode)
 291       (when gnus-carpal
 292         (gnus-carpal-setup-buffer 'server)))))
 293
 294 (defun gnus-server-prepare ()
 295   (gnus-set-format 'server-mode)
 296   (gnus-set-format 'server t)
 297   (let ((alist gnus-server-alist)
 298         (buffer-read-only nil)
 299         (opened gnus-opened-servers)
 300         done server op-ser)
 301     (erase-buffer)
 302     (setq gnus-inserted-opened-servers nil)
 303     ;; First we do the real list of servers.
 304     (while alist
 305       (unless (member (cdar alist) done)
 306         (push (cdar alist) done)
 307         (cdr (setq server (pop alist)))
 308         (when (and server (car server) (cdr server))
 309           (gnus-server-insert-server-line (car server) (cdr server))))
 310       (when (member (cdar alist) done)
 311         (pop alist)))
 312     ;; Then we insert the list of servers that have been opened in
 313     ;; this session.
 314     (while opened
 315       (when (and (not (member (caar opened) done))
 316                  ;; Just ignore ephemeral servers.
 317                  (not (member (caar opened) gnus-ephemeral-servers)))
 318         (push (caar opened) done)
 319         (gnus-server-insert-server-line
 320          (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened))))
 321          (caar opened))
 322         (push (list op-ser (caar opened)) gnus-inserted-opened-servers))
 323       (setq opened (cdr opened))))
 324   (goto-char (point-min))
 325   (gnus-server-position-point))
 326
 327 (defun gnus-server-server-name ()
 328   (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server)))
 329     (and server (symbol-name server))))
 330
 331 (defalias 'gnus-server-position-point 'gnus-goto-colon)
 332
 333 (defconst gnus-server-edit-buffer "*Gnus edit server*")
 334
 335 (defun gnus-server-update-server (server)
 336   (save-excursion
 337     (set-buffer gnus-server-buffer)
 338     (let* ((buffer-read-only nil)
 339            (entry (assoc server gnus-server-alist))
 340            (oentry (assoc (gnus-server-to-method server)
 341                           gnus-opened-servers)))
 342       (when entry
 343         (gnus-dribble-enter
 344          (concat "(gnus-server-set-info \"" server "\" '"
 345                  (prin1-to-string (cdr entry)) ")\n")))
 346       (when (or entry oentry)
 347         ;; Buffer may be narrowed.
 348         (save-restriction
 349           (widen)
 350           (when (gnus-server-goto-server server)
 351             (gnus-delete-line))
 352           (if entry
 353               (gnus-server-insert-server-line (car entry) (cdr entry))
 354             (gnus-server-insert-server-line
 355              (format "%s:%s" (caar oentry) (nth 1 (car oentry)))
 356              (car oentry)))
 357           (gnus-server-position-point))))))
 358
 359 (defun gnus-server-set-info (server info)
 360   ;; Enter a select method into the virtual server alist.
 361   (when (and server info)
 362     (gnus-dribble-enter
 363      (concat "(gnus-server-set-info \"" server "\" '"
 364              (prin1-to-string info) ")"))
 365     (let* ((server (nth 1 info))
 366            (entry (assoc server gnus-server-alist)))
 367       (if entry (setcdr entry info)
 368         (setq gnus-server-alist
 369               (nconc gnus-server-alist (list (cons server info))))))))
 370
 371 ;;; Interactive server functions.
 372
 373 (defun gnus-server-kill-server (server)
 374   "Kill the server on the current line."
 375   (interactive (list (gnus-server-server-name)))
 376   (unless (gnus-server-goto-server server)
 377     (if server (error "No such server: %s" server)
 378       (error "No server on the current line")))
 379   (unless (assoc server gnus-server-alist)
 380     (error "Read-only server %s" server))
 381   (gnus-dribble-touch)
 382   (let ((buffer-read-only nil))
 383     (gnus-delete-line))
 384   (push (assoc server gnus-server-alist) gnus-server-killed-servers)
 385   (setq gnus-server-alist (delq (car gnus-server-killed-servers)
 386                                 gnus-server-alist))
 387   (let ((groups (gnus-groups-from-server server)))
 388     (when (and groups
 389                (gnus-yes-or-no-p
 390                 (format "Kill all %s groups from this server? "
 391                         (length groups))))
 392       (dolist (group groups)
 393         (setq gnus-newsrc-alist
 394               (delq (assoc group gnus-newsrc-alist)
 395                     gnus-newsrc-alist))
 396         (when gnus-group-change-level-function
 397           (funcall gnus-group-change-level-function
 398                    group gnus-level-killed 3)))))
 399   (gnus-server-position-point))
 400
 401 (defun gnus-server-yank-server ()
 402   "Yank the previously killed server."
 403   (interactive)
 404   (unless gnus-server-killed-servers
 405     (error "No killed servers to be yanked"))
 406   (let ((alist gnus-server-alist)
 407         (server (gnus-server-server-name))
 408         (killed (car gnus-server-killed-servers)))
 409     (if (not server)
 410         (setq gnus-server-alist (nconc gnus-server-alist (list killed)))
 411       (if (string= server (caar gnus-server-alist))
 412           (push killed gnus-server-alist)
 413         (while (and (cdr alist)
 414                     (not (string= server (caadr alist))))
 415           (setq alist (cdr alist)))
 416         (if alist
 417             (setcdr alist (cons killed (cdr alist)))
 418           (setq gnus-server-alist (list killed)))))
 419     (gnus-server-update-server (car killed))
 420     (setq gnus-server-killed-servers (cdr gnus-server-killed-servers))
 421     (gnus-server-position-point)))
 422
 423 (defun gnus-server-exit ()
 424   "Return to the group buffer."
 425   (interactive)
 426   (gnus-run-hooks 'gnus-server-exit-hook)
 427   (kill-buffer (current-buffer))
 428   (gnus-configure-windows 'group t))
 429
 430 (defun gnus-server-list-servers ()
 431   "List all available servers."
 432   (interactive)
 433   (let ((cur (gnus-server-server-name)))
 434     (gnus-server-prepare)
 435     (if cur (gnus-server-goto-server cur)
 436       (goto-char (point-max))
 437       (forward-line -1))
 438     (gnus-server-position-point)))
 439
 440 (defun gnus-server-set-status (method status)
 441   "Make METHOD have STATUS."
 442   (let ((entry (assoc method gnus-opened-servers)))
 443     (if entry
 444         (setcar (cdr entry) status)
 445       (push (list method status) gnus-opened-servers))))
 446
 447 (defun gnus-opened-servers-remove (method)
 448   "Remove METHOD from the list of opened servers."
 449   (setq gnus-opened-servers (delq (assoc method gnus-opened-servers)
 450                                   gnus-opened-servers)))
 451
 452 (defun gnus-server-open-server (server)
 453   "Force an open of SERVER."
 454   (interactive (list (gnus-server-server-name)))
 455   (let ((method (gnus-server-to-method server)))
 456     (unless method
 457       (error "No such server: %s" server))
 458     (gnus-server-set-status method 'ok)
 459     (prog1
 460         (or (gnus-open-server method)
 461             (progn (message "Couldn't open %s" server) nil))
 462       (gnus-server-update-server server)
 463       (gnus-server-position-point))))
 464
 465 (defun gnus-server-open-all-servers ()
 466   "Open all servers."
 467   (interactive)
 468   (let ((servers gnus-inserted-opened-servers))
 469     (while servers
 470       (gnus-server-open-server (car (pop servers))))))
 471
 472 (defun gnus-server-close-server (server)
 473   "Close SERVER."
 474   (interactive (list (gnus-server-server-name)))
 475   (let ((method (gnus-server-to-method server)))
 476     (unless method
 477       (error "No such server: %s" server))
 478     (gnus-server-set-status method 'closed)
 479     (prog1
 480         (gnus-close-server method)
 481       (gnus-server-update-server server)
 482       (gnus-server-position-point))))
 483
 484 (defun gnus-server-close-all-servers ()
 485   "Close all servers."
 486   (interactive)
 487   (dolist (server gnus-inserted-opened-servers)
 488     (gnus-server-close-server (car server))))
 489
 490 (defun gnus-server-deny-server (server)
 491   "Make sure SERVER will never be attempted opened."
 492   (interactive (list (gnus-server-server-name)))
 493   (let ((method (gnus-server-to-method server)))
 494     (unless method
 495       (error "No such server: %s" server))
 496     (gnus-server-set-status method 'denied))
 497   (gnus-server-update-server server)
 498   (gnus-server-position-point)
 499   t)
 500
 501 (defun gnus-server-remove-denials ()
 502   "Make all denied servers into closed servers."
 503   (interactive)
 504   (dolist (server gnus-opened-servers)
 505     (when (eq (nth 1 server) 'denied)
 506       (setcar (nthcdr 1 server) 'closed)))
 507   (gnus-server-list-servers))
 508
 509 (defun gnus-server-copy-server (from to)
 510   (interactive
 511    (list
 512     (or (gnus-server-server-name)
 513         (error "No server on the current line"))
 514     (read-string "Copy to: ")))
 515   (unless from
 516     (error "No server on current line"))
 517   (unless (and to (not (string= to "")))
 518     (error "No name to copy to"))
 519   (when (assoc to gnus-server-alist)
 520     (error "%s already exists" to))
 521   (unless (gnus-server-to-method from)
 522     (error "%s: no such server" from))
 523   (let ((to-entry (cons from (gnus-copy-sequence
 524                               (gnus-server-to-method from)))))
 525     (setcar to-entry to)
 526     (setcar (nthcdr 2 to-entry) to)
 527     (push to-entry gnus-server-killed-servers)
 528     (gnus-server-yank-server)))
 529
 530 (defun gnus-server-add-server (how where)
 531   (interactive
 532    (list (intern (completing-read "Server method: "
 533                                   gnus-valid-select-methods nil t))
 534          (read-string "Server name: ")))
 535   (when (assq where gnus-server-alist)
 536     (error "Server with that name already defined"))
 537   (push (list where how where) gnus-server-killed-servers)
 538   (gnus-server-yank-server))
 539
 540 (defun gnus-server-goto-server (server)
 541   "Jump to a server line."
 542   (interactive
 543    (list (completing-read "Goto server: " gnus-server-alist nil t)))
 544   (let ((to (text-property-any (point-min) (point-max)
 545                                'gnus-server (intern server))))
 546     (when to
 547       (goto-char to)
 548       (gnus-server-position-point))))
 549
 550 (defun gnus-server-edit-server (server)
 551   "Edit the server on the current line."
 552   (interactive (list (gnus-server-server-name)))
 553   (unless server
 554     (error "No server on current line"))
 555   (unless (assoc server gnus-server-alist)
 556     (error "This server can't be edited"))
 557   (let ((info (cdr (assoc server gnus-server-alist))))
 558     (gnus-close-server info)
 559     (gnus-edit-form
 560      info "Editing the server."
 561      `(lambda (form)
 562         (gnus-server-set-info ,server form)
 563         (gnus-server-list-servers)
 564         (gnus-server-position-point)))))
 565
 566 (defun gnus-server-scan-server (server)
 567   "Request a scan from the current server."
 568   (interactive (list (gnus-server-server-name)))
 569   (let ((method (gnus-server-to-method server)))
 570     (if (not (gnus-get-function method 'request-scan))
 571         (error "Server %s can't scan" (car method))
 572       (gnus-message 3 "Scanning %s..." server)
 573       (gnus-request-scan nil method)
 574       (gnus-message 3 "Scanning %s...done" server))))
 575
 576 (defun gnus-server-read-server-in-server-buffer (server)
 577   "Browse a server in server buffer."
 578   (interactive (list (gnus-server-server-name)))
 579   (let (gnus-server-browse-in-group-buffer)
 580     (gnus-server-read-server server)))
 581
 582 (defun gnus-server-read-server (server)
 583   "Browse a server."
 584   (interactive (list (gnus-server-server-name)))
 585   (let ((buf (current-buffer)))
 586     (prog1
 587         (gnus-browse-foreign-server server buf)
 588       (save-excursion
 589         (set-buffer buf)
 590         (gnus-server-update-server (gnus-server-server-name))
 591         (gnus-server-position-point)))))
 592
 593 (defun gnus-server-pick-server (e)
 594   (interactive "e")
 595   (mouse-set-point e)
 596   (gnus-server-read-server (gnus-server-server-name)))
 597
 598 \f
 599 ;;;
 600 ;;; Browse Server Mode
 601 ;;;
 602
 603 (defvar gnus-browse-menu-hook nil
 604   "*Hook run after the creation of the browse mode menu.")
 605
 606 (defvar gnus-browse-mode-hook nil)
 607 (defvar gnus-browse-mode-map nil)
 608 (put 'gnus-browse-mode 'mode-class 'special)
 609
 610 (unless gnus-browse-mode-map
 611   (setq gnus-browse-mode-map (make-keymap))
 612   (suppress-keymap gnus-browse-mode-map)
 613
 614   (gnus-define-keys
 615       gnus-browse-mode-map
 616     " " gnus-browse-read-group
 617     "=" gnus-browse-select-group
 618     "n" gnus-browse-next-group
 619     "p" gnus-browse-prev-group
 620     "\177" gnus-browse-prev-group
 621     [delete] gnus-browse-prev-group
 622     "N" gnus-browse-next-group
 623     "P" gnus-browse-prev-group
 624     "\M-n" gnus-browse-next-group
 625     "\M-p" gnus-browse-prev-group
 626     "\r" gnus-browse-select-group
 627     "u" gnus-browse-unsubscribe-current-group
 628     "l" gnus-browse-exit
 629     "L" gnus-browse-exit
 630     "q" gnus-browse-exit
 631     "Q" gnus-browse-exit
 632     "\C-c\C-c" gnus-browse-exit
 633     "?" gnus-browse-describe-briefly
 634
 635     "\C-c\C-i" gnus-info-find-node
 636     "\C-c\C-b" gnus-bug))
 637
 638 (defun gnus-browse-make-menu-bar ()
 639   (gnus-turn-off-edit-menu 'browse)
 640   (unless (boundp 'gnus-browse-menu)
 641     (easy-menu-define
 642      gnus-browse-menu gnus-browse-mode-map ""
 643      '("Browse"
 644        ["Subscribe" gnus-browse-unsubscribe-current-group t]
 645        ["Read" gnus-browse-read-group t]
 646        ["Select" gnus-browse-select-group t]
 647        ["Next" gnus-browse-next-group t]
 648        ["Prev" gnus-browse-prev-group t]
 649        ["Exit" gnus-browse-exit t]))
 650     (gnus-run-hooks 'gnus-browse-menu-hook)))
 651
 652 (defvar gnus-browse-current-method nil)
 653 (defvar gnus-browse-return-buffer nil)
 654
 655 (defvar gnus-browse-buffer "*Gnus Browse Server*")
 656
 657 (defun gnus-browse-foreign-server (server &optional return-buffer)
 658   "Browse the server SERVER."
 659   (setq gnus-browse-current-method (gnus-server-to-method server))
 660   (setq gnus-browse-return-buffer return-buffer)
 661   (let* ((method gnus-browse-current-method)
 662          (orig-select-method gnus-select-method)
 663          (gnus-select-method method)
 664          groups group)
 665     (gnus-message 5 "Connecting to %s..." (nth 1 method))
 666     (cond
 667      ((not (gnus-check-server method))
 668       (gnus-message
 669        1 "Unable to contact server %s: %s" (nth 1 method)
 670        (gnus-status-message method))
 671       nil)
 672      ((not
 673        (prog2
 674            (gnus-message 6 "Reading active file...")
 675            (gnus-request-list method)
 676          (gnus-message 6 "Reading active file...done")))
 677       (gnus-message
 678        1 "Couldn't request list: %s" (gnus-status-message method))
 679       nil)
 680      (t
 681       (save-excursion
 682         (set-buffer nntp-server-buffer)
 683         (let ((cur (current-buffer)))
 684           (goto-char (point-min))
 685           (unless (string= gnus-ignored-newsgroups "")
 686             (delete-matching-lines gnus-ignored-newsgroups))
 687           (while (not (eobp))
 688             (ignore-errors
 689               (push (cons
 690                      (if (eq (char-after) ?\")
 691                          (read cur)
 692                        (let ((p (point)) (name ""))
 693                          (skip-chars-forward "^ \t\\\\")
 694                          (setq name (buffer-substring p (point)))
 695                          (while (eq (char-after) ?\\)
 696                            (setq p (1+ (point)))
 697                            (forward-char 2)
 698                            (skip-chars-forward "^ \t\\\\")
 699                            (setq name (concat name (buffer-substring
 700                                                     p (point)))))
 701                          name))
 702                      (let ((last (read cur)))
 703                        (cons (read cur) last)))
 704                     groups))
 705             (forward-line))))
 706       (setq groups (sort groups
 707                          (lambda (l1 l2)
 708                            (string< (car l1) (car l2)))))
 709       (if gnus-server-browse-in-group-buffer
 710           (let* ((gnus-select-method orig-select-method)
 711                  (gnus-group-listed-groups
 712                   (mapcar (lambda (group)
 713                             (let ((name
 714                                    (gnus-group-prefixed-name
 715                                     (car group) method)))
 716                               (gnus-set-active name (cdr group))
 717                               name))
 718                           groups)))
 719             (gnus-configure-windows 'group)
 720             (funcall gnus-group-prepare-function
 721                      gnus-level-killed 'ignore 1 'ignore))
 722         (gnus-get-buffer-create gnus-browse-buffer)
 723         (when gnus-carpal
 724           (gnus-carpal-setup-buffer 'browse))
 725         (gnus-configure-windows 'browse)
 726         (buffer-disable-undo)
 727         (let ((buffer-read-only nil))
 728           (erase-buffer))
 729         (gnus-browse-mode)
 730         (setq mode-line-buffer-identification
 731               (list
 732                (format
 733                 "Gnus: %%b {%s:%s}" (car method) (cadr method))))
 734         (let ((buffer-read-only nil) charset
 735               (prefix (let ((gnus-select-method orig-select-method))
 736                         (gnus-group-prefixed-name "" method))))
 737           (while groups
 738             (setq group (car groups))
 739             (setq charset (gnus-group-name-charset method (car group)))
 740             (gnus-add-text-properties
 741              (point)
 742              (prog1 (1+ (point))
 743                (insert
 744                 (format "%c%7d: %s\n"
 745                         (let ((level (gnus-group-level (concat prefix (car group)))))
 746                               (cond
 747                                ((<= level gnus-level-subscribed) ? )
 748                                ((<= level gnus-level-unsubscribed) ?U)
 749                                ((= level gnus-level-zombie) ?Z)
 750                                (t ?K)))
 751                         (max 0 (- (1+ (cddr group)) (cadr group)))
 752                         (gnus-group-name-decode (car group) charset))))
 753              (list 'gnus-group (car group)))
 754             (setq groups (cdr groups))))
 755         (switch-to-buffer (current-buffer)))
 756       (goto-char (point-min))
 757       (gnus-group-position-point)
 758       (gnus-message 5 "Connecting to %s...done" (nth 1 method))
 759       t))))
 760
 761 (defun gnus-browse-mode ()
 762   "Major mode for browsing a foreign server.
 763
 764 All normal editing commands are switched off.
 765
 766 \\<gnus-browse-mode-map>
 767 The only things you can do in this buffer is
 768
 769 1) `\\[gnus-browse-unsubscribe-current-group]' to subscribe to a group.
 770 The group will be inserted into the group buffer upon exit from this
 771 buffer.
 772
 773 2) `\\[gnus-browse-read-group]' to read a group ephemerally.
 774
 775 3) `\\[gnus-browse-exit]' to return to the group buffer."
 776   (interactive)
 777   (kill-all-local-variables)
 778   (when (gnus-visual-p 'browse-menu 'menu)
 779     (gnus-browse-make-menu-bar))
 780   (gnus-simplify-mode-line)
 781   (setq major-mode 'gnus-browse-mode)
 782   (setq mode-name "Browse Server")
 783   (setq mode-line-process nil)
 784   (use-local-map gnus-browse-mode-map)
 785   (buffer-disable-undo)
 786   (setq truncate-lines t)
 787   (gnus-set-default-directory)
 788   (setq buffer-read-only t)
 789   (gnus-run-hooks 'gnus-browse-mode-hook))
 790
 791 (defun gnus-browse-read-group (&optional no-article)
 792   "Enter the group at the current line."
 793   (interactive)
 794   (let ((group (gnus-browse-group-name)))
 795     (if (or (not (gnus-get-info group))
 796             (gnus-ephemeral-group-p group))
 797         (unless (gnus-group-read-ephemeral-group
 798                  (gnus-group-real-name group) gnus-browse-current-method nil
 799                  (cons (current-buffer) 'browse))
 800           (error "Couldn't enter %s" group))
 801       (unless (gnus-group-read-group nil no-article group)
 802         (error "Couldn't enter %s" group)))))
 803
 804 (defun gnus-browse-select-group ()
 805   "Select the current group."
 806   (interactive)
 807   (gnus-browse-read-group 'no))
 808
 809 (defun gnus-browse-next-group (n)
 810   "Go to the next group."
 811   (interactive "p")
 812   (prog1
 813       (forward-line n)
 814     (gnus-group-position-point)))
 815
 816 (defun gnus-browse-prev-group (n)
 817   "Go to the next group."
 818   (interactive "p")
 819   (gnus-browse-next-group (- n)))
 820
 821 (defun gnus-browse-unsubscribe-current-group (arg)
 822   "(Un)subscribe to the next ARG groups."
 823   (interactive "p")
 824   (when (eobp)
 825     (error "No group at current line"))
 826   (let ((ward (if (< arg 0) -1 1))
 827         (arg (abs arg)))
 828     (while (and (> arg 0)
 829                 (not (eobp))
 830                 (gnus-browse-unsubscribe-group)
 831                 (zerop (gnus-browse-next-group ward)))
 832       (decf arg))
 833     (gnus-group-position-point)
 834     (when (/= 0 arg)
 835       (gnus-message 7 "No more newsgroups"))
 836     arg))
 837
 838 (defun gnus-browse-group-name ()
 839   (save-excursion
 840     (beginning-of-line)
 841     (let ((name (get-text-property (point) 'gnus-group)))
 842       (when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t)
 843         (gnus-group-prefixed-name
 844          (or name
 845              (match-string-no-properties 1))
 846          gnus-browse-current-method)))))
 847
 848 (defun gnus-browse-unsubscribe-group ()
 849   "Toggle subscription of the current group in the browse buffer."
 850   (let ((sub nil)
 851         (buffer-read-only nil)
 852         group)
 853     (save-excursion
 854       (beginning-of-line)
 855       ;; If this group it killed, then we want to subscribe it.
 856       (unless (eq (char-after) ? )
 857         (setq sub t))
 858       (setq group (gnus-browse-group-name))
 859       ;;;;
 860       ;;(when (and sub
 861       ;;                 (cadr (gnus-gethash group gnus-newsrc-hashtb)))
 862       ;;(error "Group already subscribed"))
 863       (if sub
 864           (progn
 865             ;; Make sure the group has been properly removed before we
 866             ;; subscribe to it.
 867             (gnus-kill-ephemeral-group group)
 868             (gnus-group-change-level
 869              (list t group gnus-level-default-subscribed
 870                    nil nil (if (gnus-server-equal
 871                                 gnus-browse-current-method "native")
 872                                nil
 873                              (gnus-method-simplify
 874                               gnus-browse-current-method)))
 875              gnus-level-default-subscribed (gnus-group-level group)
 876              (and (car (nth 1 gnus-newsrc-alist))
 877                   (gnus-gethash (car (nth 1 gnus-newsrc-alist))
 878                                 gnus-newsrc-hashtb))
 879              t)
 880             (delete-char 1)
 881             (insert ? ))
 882         (gnus-group-change-level
 883          group gnus-level-unsubscribed gnus-level-default-subscribed)
 884         (delete-char 1)
 885         (insert ?U)))
 886     t))
 887
 888 (defun gnus-browse-exit ()
 889   "Quit browsing and return to the group buffer."
 890   (interactive)
 891   (when (eq major-mode 'gnus-browse-mode)
 892     (kill-buffer (current-buffer)))
 893   ;; Insert the newly subscribed groups in the group buffer.
 894   (save-excursion
 895     (set-buffer gnus-group-buffer)
 896     (gnus-group-list-groups nil))
 897   (if gnus-browse-return-buffer
 898       (gnus-configure-windows 'server 'force)
 899     (gnus-configure-windows 'group 'force)))
 900
 901 (defun gnus-browse-describe-briefly ()
 902   "Give a one line description of the group mode commands."
 903   (interactive)
 904   (gnus-message 6
 905                 (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")))
 906
 907 (defun gnus-server-regenerate-server ()
 908   "Issue a command to the server to regenerate all its data structures."
 909   (interactive)
 910   (let ((server (gnus-server-server-name)))
 911     (unless server
 912       (error "No server on the current line"))
 913     (condition-case ()
 914         (gnus-get-function (gnus-server-to-method server)
 915                            'request-regenerate)
 916       (error
 917         (error "This backend doesn't support regeneration")))
 918     (gnus-message 5 "Requesting regeneration of %s..." server)
 919     (unless (gnus-open-server server)
 920       (error "Couldn't open server"))
 921     (if (gnus-request-regenerate server)
 922         (gnus-message 5 "Requesting regeneration of %s...done" server)
 923       (gnus-message 5 "Couldn't regenerate %s" server))))
 924
 925 (provide 'gnus-srvr)
 926
 927 ;;; gnus-srvr.el ends here