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