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