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