code.delx.au - gnu-emacs/blob - lisp/gnus/gnus-srvr.el

   1 ;;; gnus-srvr.el --- virtual server support for Gnus
   2
   3 ;; Copyright (C) 1995-2016 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 3 of the License, or
  13 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (eval-when-compile (require 'cl))
  28
  29 (require 'gnus)
  30 (require 'gnus-start)
  31 (require 'gnus-spec)
  32 (require 'gnus-group)
  33 (require 'gnus-int)
  34 (require 'gnus-range)
  35 (require 'gnus-cloud)
  36
  37 (autoload 'gnus-group-make-nnir-group "nnir")
  38
  39 (defcustom gnus-server-mode-hook nil
  40   "Hook run in `gnus-server-mode' buffers."
  41   :group 'gnus-server
  42   :type 'hook)
  43
  44 (defcustom gnus-server-exit-hook nil
  45   "Hook run when exiting the server buffer."
  46   :group 'gnus-server
  47   :type 'hook)
  48
  49 (defcustom gnus-server-line-format "     {%(%h:%w%)} %s%a%c\n"
  50   "Format of server lines.
  51 It works along the same lines as a normal formatting string,
  52 with some simple extensions.
  53
  54 The following specs are understood:
  55
  56 %h back end
  57 %n name
  58 %w address
  59 %s status
  60 %a agent covered
  61
  62 General format specifiers can also be used.
  63 See Info node `(gnus)Formatting Variables'."
  64   :link '(custom-manual "(gnus)Formatting Variables")
  65   :group 'gnus-server-visual
  66   :type 'string)
  67
  68 (defcustom gnus-server-mode-line-format "Gnus: %%b"
  69   "The format specification for the server mode line."
  70   :group 'gnus-server-visual
  71   :type 'string)
  72
  73 (defcustom gnus-server-browse-in-group-buffer nil
  74   "Whether server browsing should take place in the group buffer.
  75 If nil, a faster, but more primitive, buffer is used instead."
  76   :version "22.1"
  77   :group 'gnus-server-visual
  78   :type 'boolean)
  79
  80 ;;; Internal variables.
  81
  82 (defvar gnus-tmp-how)
  83 (defvar gnus-tmp-name)
  84 (defvar gnus-tmp-where)
  85 (defvar gnus-tmp-status)
  86 (defvar gnus-tmp-agent)
  87 (defvar gnus-tmp-cloud)
  88 (defvar gnus-tmp-news-server)
  89 (defvar gnus-tmp-news-method)
  90 (defvar gnus-tmp-user-defined)
  91
  92 (defvar gnus-inserted-opened-servers nil)
  93
  94 (defvar gnus-server-line-format-alist
  95   `((?h gnus-tmp-how ?s)
  96     (?n gnus-tmp-name ?s)
  97     (?w gnus-tmp-where ?s)
  98     (?s gnus-tmp-status ?s)
  99     (?a gnus-tmp-agent ?s)
 100     (?c gnus-tmp-cloud ?s)))
 101
 102 (defvar gnus-server-mode-line-format-alist
 103   `((?S gnus-tmp-news-server ?s)
 104     (?M gnus-tmp-news-method ?s)
 105     (?u gnus-tmp-user-defined ?s)))
 106
 107 (defvar gnus-server-line-format-spec nil)
 108 (defvar gnus-server-mode-line-format-spec nil)
 109 (defvar gnus-server-killed-servers nil)
 110
 111 (defvar gnus-server-mode-map)
 112
 113 (defcustom gnus-server-menu-hook nil
 114   "Hook run after the creation of the server mode menu."
 115   :type 'hook
 116   :group 'gnus-server)
 117
 118 (defun gnus-server-make-menu-bar ()
 119   (gnus-turn-off-edit-menu 'server)
 120   (unless (boundp 'gnus-server-server-menu)
 121     (easy-menu-define
 122      gnus-server-server-menu gnus-server-mode-map ""
 123      '("Server"
 124        ["Add..." gnus-server-add-server t]
 125        ["Browse" gnus-server-read-server t]
 126        ["Scan" gnus-server-scan-server t]
 127        ["List" gnus-server-list-servers t]
 128        ["Kill" gnus-server-kill-server t]
 129        ["Yank" gnus-server-yank-server t]
 130        ["Copy" gnus-server-copy-server t]
 131        ["Show" gnus-server-show-server t]
 132        ["Edit" gnus-server-edit-server t]
 133        ["Regenerate" gnus-server-regenerate-server t]
 134        ["Compact" gnus-server-compact-server t]
 135        ["Exit" gnus-server-exit t]))
 136
 137     (easy-menu-define
 138      gnus-server-connections-menu gnus-server-mode-map ""
 139      '("Connections"
 140        ["Open" gnus-server-open-server t]
 141        ["Close" gnus-server-close-server t]
 142        ["Offline" gnus-server-offline-server t]
 143        ["Deny" gnus-server-deny-server t]
 144        ["Toggle Cloud Sync for this server" gnus-server-toggle-cloud-server t]
 145        ["Toggle Cloud Sync Host" gnus-server-toggle-cloud-method-server t]
 146        "---"
 147        ["Open All" gnus-server-open-all-servers t]
 148        ["Close All" gnus-server-close-all-servers t]
 149        ["Reset All" gnus-server-remove-denials t]))
 150
 151     (gnus-run-hooks 'gnus-server-menu-hook)))
 152
 153 (defvar gnus-server-mode-map nil)
 154 (put 'gnus-server-mode 'mode-class 'special)
 155
 156 (unless gnus-server-mode-map
 157   (setq gnus-server-mode-map (make-sparse-keymap))
 158   (suppress-keymap gnus-server-mode-map)
 159
 160   (gnus-define-keys gnus-server-mode-map
 161     " " gnus-server-read-server-in-server-buffer
 162     "\r" gnus-server-read-server
 163     [mouse-2] gnus-server-pick-server
 164     "q" gnus-server-exit
 165     "l" gnus-server-list-servers
 166     "k" gnus-server-kill-server
 167     "y" gnus-server-yank-server
 168     "c" gnus-server-copy-server
 169     "a" gnus-server-add-server
 170     "e" gnus-server-edit-server
 171     "S" gnus-server-show-server
 172     "s" gnus-server-scan-server
 173
 174     "O" gnus-server-open-server
 175     "\M-o" gnus-server-open-all-servers
 176     "C" gnus-server-close-server
 177     "\M-c" gnus-server-close-all-servers
 178     "D" gnus-server-deny-server
 179     "L" gnus-server-offline-server
 180     "R" gnus-server-remove-denials
 181
 182     "n" next-line
 183     "p" previous-line
 184
 185     "g" gnus-server-regenerate-server
 186
 187     "G" gnus-group-make-nnir-group
 188
 189     "z" gnus-server-compact-server
 190
 191     "i" gnus-server-toggle-cloud-server
 192     "I" gnus-server-toggle-cloud-method-server
 193
 194     "\C-c\C-i" gnus-info-find-node
 195     "\C-c\C-b" gnus-bug))
 196
 197 (defface gnus-server-agent
 198   '((((class color) (background light)) (:foreground "PaleTurquoise" :bold t))
 199     (((class color) (background dark)) (:foreground "PaleTurquoise" :bold t))
 200     (t (:bold t)))
 201   "Face used for displaying AGENTIZED servers"
 202   :group 'gnus-server-visual)
 203 ;; backward-compatibility alias
 204 (put 'gnus-server-agent-face 'face-alias 'gnus-server-agent)
 205 (put 'gnus-server-agent-face 'obsolete-face "22.1")
 206
 207 (defface gnus-server-cloud
 208   '((((class color) (background light)) (:foreground "ForestGreen" :bold t))
 209     (((class color) (background dark)) (:foreground "PaleGreen" :bold t))
 210     (t (:bold t)))
 211   "Face used for displaying Cloud-synced servers"
 212   :group 'gnus-server-visual)
 213
 214 (defface gnus-server-cloud-host
 215   '((((class color) (background light)) (:foreground "ForestGreen" :inverse-video t :italic t))
 216     (((class color) (background dark)) (:foreground "PaleGreen" :inverse-video t :italic t))
 217     (t (:inverse-video t :italic t)))
 218   "Face used for displaying the Cloud Host"
 219   :group 'gnus-server-visual)
 220
 221 (defface gnus-server-opened
 222   '((((class color) (background light)) (:foreground "Green3" :bold t))
 223     (((class color) (background dark)) (:foreground "Green1" :bold t))
 224     (t (:bold t)))
 225   "Face used for displaying OPENED servers"
 226   :group 'gnus-server-visual)
 227 ;; backward-compatibility alias
 228 (put 'gnus-server-opened-face 'face-alias 'gnus-server-opened)
 229 (put 'gnus-server-opened-face 'obsolete-face "22.1")
 230
 231 (defface gnus-server-closed
 232   '((((class color) (background light)) (:foreground "Steel Blue" :italic t))
 233     (((class color) (background dark))
 234      (:foreground "LightBlue" :italic t))
 235     (t (:italic t)))
 236   "Face used for displaying CLOSED servers"
 237   :group 'gnus-server-visual)
 238 ;; backward-compatibility alias
 239 (put 'gnus-server-closed-face 'face-alias 'gnus-server-closed)
 240 (put 'gnus-server-closed-face 'obsolete-face "22.1")
 241
 242 (defface gnus-server-denied
 243   '((((class color) (background light)) (:foreground "Red" :bold t))
 244     (((class color) (background dark)) (:foreground "Pink" :bold t))
 245     (t (:inverse-video t :bold t)))
 246   "Face used for displaying DENIED servers"
 247   :group 'gnus-server-visual)
 248 ;; backward-compatibility alias
 249 (put 'gnus-server-denied-face 'face-alias 'gnus-server-denied)
 250 (put 'gnus-server-denied-face 'obsolete-face "22.1")
 251
 252 (defface gnus-server-offline
 253   '((((class color) (background light)) (:foreground "Orange" :bold t))
 254     (((class color) (background dark)) (:foreground "Yellow" :bold t))
 255     (t (:inverse-video t :bold t)))
 256   "Face used for displaying OFFLINE servers"
 257   :group 'gnus-server-visual)
 258 ;; backward-compatibility alias
 259 (put 'gnus-server-offline-face 'face-alias 'gnus-server-offline)
 260 (put 'gnus-server-offline-face 'obsolete-face "22.1")
 261
 262 (defvar gnus-server-font-lock-keywords
 263   '(("(\\(agent\\))" 1 'gnus-server-agent)
 264     ("(\\(cloud[-]sync\\))" 1 'gnus-server-cloud)
 265     ("(\\(CLOUD[-]HOST\\))" 1 'gnus-server-cloud-host)
 266     ("(\\(opened\\))" 1 'gnus-server-opened)
 267     ("(\\(closed\\))" 1 'gnus-server-closed)
 268     ("(\\(offline\\))" 1 'gnus-server-offline)
 269     ("(\\(denied\\))" 1 'gnus-server-denied)))
 270
 271 (defun gnus-server-mode ()
 272   "Major mode for listing and editing servers.
 273
 274 All normal editing commands are switched off.
 275 \\<gnus-server-mode-map>
 276 For more in-depth information on this mode, read the manual
 277 \(`\\[gnus-info-find-node]').
 278
 279 The following commands are available:
 280
 281 \\{gnus-server-mode-map}"
 282   ;; FIXME: Use define-derived-mode.
 283   (interactive)
 284   (when (gnus-visual-p 'server-menu 'menu)
 285     (gnus-server-make-menu-bar))
 286   (kill-all-local-variables)
 287   (gnus-simplify-mode-line)
 288   (setq major-mode 'gnus-server-mode)
 289   (setq mode-name "Server")
 290   (gnus-set-default-directory)
 291   (setq mode-line-process nil)
 292   (use-local-map gnus-server-mode-map)
 293   (buffer-disable-undo)
 294   (setq truncate-lines t)
 295   (setq buffer-read-only t)
 296   (set (make-local-variable 'font-lock-defaults)
 297        '(gnus-server-font-lock-keywords t))
 298   (gnus-run-mode-hooks 'gnus-server-mode-hook))
 299
 300 (defun gnus-server-insert-server-line (name method)
 301   (let* ((gnus-tmp-name name)
 302          (gnus-tmp-how (car method))
 303          (gnus-tmp-where (nth 1 method))
 304          (elem (assoc method gnus-opened-servers))
 305          (gnus-tmp-status
 306           (cond
 307            ((eq (nth 1 elem) 'denied) "(denied)")
 308            ((eq (nth 1 elem) 'offline) "(offline)")
 309            (t
 310             (condition-case nil
 311                 (if (or (gnus-server-opened method)
 312                         (eq (nth 1 elem) 'ok))
 313                     "(opened)"
 314                   "(closed)")
 315               ((error) "(error)")))))
 316          (gnus-tmp-agent (if (and gnus-agent
 317                                   (gnus-agent-method-p method))
 318                              " (agent)"
 319                            ""))
 320          (gnus-tmp-cloud (concat
 321                           (if (gnus-cloud-host-server-p gnus-tmp-name)
 322                               " (CLOUD-HOST)"
 323                             "")
 324                           (if (gnus-cloud-server-p gnus-tmp-name)
 325                              " (cloud-sync)"
 326                             ""))))
 327     (beginning-of-line)
 328     (add-text-properties
 329      (point)
 330      (prog1 (1+ (point))
 331        ;; Insert the text.
 332        (eval gnus-server-line-format-spec))
 333      (list 'gnus-server (intern gnus-tmp-name)
 334            'gnus-named-server (intern (gnus-method-to-server method t))))))
 335
 336 (defun gnus-enter-server-buffer ()
 337   "Set up the server buffer."
 338   (gnus-server-setup-buffer)
 339   (gnus-configure-windows 'server)
 340   ;; Usually `gnus-configure-windows' will finish with the
 341   ;; `gnus-server-buffer' selected as the current buffer, but not always (I
 342   ;; bumped into it when starting from a dedicated *Group* frame, and
 343   ;; gnus-configure-windows opened *Server* into its own dedicated frame).
 344   (with-current-buffer (get-buffer gnus-server-buffer)
 345     (gnus-server-prepare)))
 346
 347 (defun gnus-server-setup-buffer ()
 348   "Initialize the server buffer."
 349   (unless (get-buffer gnus-server-buffer)
 350     (with-current-buffer (gnus-get-buffer-create gnus-server-buffer)
 351       (gnus-server-mode))))
 352
 353 (defun gnus-server-prepare ()
 354   (gnus-set-format 'server-mode)
 355   (gnus-set-format 'server t)
 356   (let ((alist gnus-server-alist)
 357         (buffer-read-only nil)
 358         done server op-ser)
 359     (erase-buffer)
 360     (setq gnus-inserted-opened-servers nil)
 361     ;; First we do the real list of servers.
 362     (while alist
 363       (unless (member (cdar alist) done)
 364         (push (cdar alist) done)
 365         (setq server (pop alist))
 366         (when (and server (car server) (cdr server))
 367           (gnus-server-insert-server-line (car server) (cdr server))))
 368       (when (member (cdar alist) done)
 369         (pop alist)))
 370     ;; Then we insert the list of servers that have been opened in
 371     ;; this session.
 372     (dolist (open gnus-opened-servers)
 373       (when (and (not (member (car open) done))
 374                  ;; Just ignore ephemeral servers.
 375                  (not (gnus-method-ephemeral-p (car open))))
 376         (push (car open) done)
 377         (gnus-server-insert-server-line
 378          (setq op-ser (format "%s:%s" (caar open) (nth 1 (car open))))
 379          (car open))
 380         (push (list op-ser (car open)) gnus-inserted-opened-servers))))
 381   (goto-char (point-min))
 382   (gnus-server-position-point))
 383
 384 (defun gnus-server-server-name ()
 385   (let ((server (get-text-property (point-at-bol) 'gnus-server)))
 386     (and server (symbol-name server))))
 387
 388 (defun gnus-server-named-server ()
 389   "Return a server name that matches one of the names returned by
 390 `gnus-method-to-server'."
 391   (let ((server (get-text-property (point-at-bol) 'gnus-named-server)))
 392     (and server (symbol-name server))))
 393
 394 (defalias 'gnus-server-position-point 'gnus-goto-colon)
 395
 396 (defconst gnus-server-edit-buffer "*Gnus edit server*")
 397
 398 (defun gnus-server-update-server (server)
 399   (with-current-buffer gnus-server-buffer
 400     (let* ((buffer-read-only nil)
 401            (entry (assoc server gnus-server-alist))
 402            (oentry (assoc (gnus-server-to-method server)
 403                           gnus-opened-servers)))
 404       (when entry
 405         (gnus-dribble-enter
 406          (concat "(gnus-server-set-info \"" server "\" '"
 407                  (gnus-prin1-to-string (cdr entry)) ")")
 408          (concat "^(gnus-server-set-info \"" (regexp-quote server) "\"")))
 409       (when (or entry oentry)
 410         ;; Buffer may be narrowed.
 411         (save-restriction
 412           (widen)
 413           (when (gnus-server-goto-server server)
 414             (gnus-delete-line))
 415           (if entry
 416               (gnus-server-insert-server-line (car entry) (cdr entry))
 417             (gnus-server-insert-server-line
 418              (format "%s:%s" (caar oentry) (nth 1 (car oentry)))
 419              (car oentry)))
 420           (gnus-server-position-point))))))
 421
 422 (defun gnus-server-set-info (server info)
 423   ;; Enter a select method into the virtual server alist.
 424   (when (and server info)
 425     (gnus-dribble-enter
 426      (concat "(gnus-server-set-info \"" server "\" '"
 427              (gnus-prin1-to-string info) ")")
 428      (concat "^(gnus-server-set-info \"" (regexp-quote server) "\""))
 429     (let* ((server (nth 1 info))
 430            (entry (assoc server gnus-server-alist))
 431            (cached (assoc server gnus-server-method-cache)))
 432       (if cached
 433           (setq gnus-server-method-cache
 434                 (delq cached gnus-server-method-cache)))
 435       (if entry
 436           (progn
 437             ;; Remove the server from `gnus-opened-servers' since
 438             ;; it has never been opened with the new `info' yet.
 439             (gnus-opened-servers-remove (cdr entry))
 440             ;; Don't make a new Lisp object.
 441             (setcar (cdr entry) (car info))
 442             (setcdr (cdr entry) (cdr info)))
 443         (setq gnus-server-alist
 444               (nconc gnus-server-alist (list (cons server info))))))))
 445
 446 ;;; Interactive server functions.
 447
 448 (defun gnus-server-kill-server (server)
 449   "Kill the server on the current line."
 450   (interactive (list (gnus-server-server-name)))
 451   (unless (gnus-server-goto-server server)
 452     (if server (error "No such server: %s" server)
 453       (error "No server on the current line")))
 454   (unless (assoc server gnus-server-alist)
 455     (error "Read-only server %s" server))
 456   (gnus-dribble-touch)
 457   (let ((buffer-read-only nil))
 458     (gnus-delete-line))
 459   (push (assoc server gnus-server-alist) gnus-server-killed-servers)
 460   (setq gnus-server-alist (delq (car gnus-server-killed-servers)
 461                                 gnus-server-alist))
 462   (let ((groups (gnus-groups-from-server server)))
 463     (when (and groups
 464                (gnus-yes-or-no-p
 465                 (format "Kill all %s groups from this server? "
 466                         (length groups))))
 467       (dolist (group groups)
 468         (setq gnus-newsrc-alist
 469               (delq (assoc group gnus-newsrc-alist)
 470                     gnus-newsrc-alist))
 471         (when gnus-group-change-level-function
 472           (funcall gnus-group-change-level-function
 473                    group gnus-level-killed 3)))))
 474   (gnus-server-position-point))
 475
 476 (defun gnus-server-yank-server ()
 477   "Yank the previously killed server."
 478   (interactive)
 479   (unless gnus-server-killed-servers
 480     (error "No killed servers to be yanked"))
 481   (let ((alist gnus-server-alist)
 482         (server (gnus-server-server-name))
 483         (killed (car gnus-server-killed-servers)))
 484     (if (not server)
 485         (setq gnus-server-alist (nconc gnus-server-alist (list killed)))
 486       (if (string= server (caar gnus-server-alist))
 487           (push killed gnus-server-alist)
 488         (while (and (cdr alist)
 489                     (not (string= server (caadr alist))))
 490           (setq alist (cdr alist)))
 491         (if alist
 492             (setcdr alist (cons killed (cdr alist)))
 493           (setq gnus-server-alist (list killed)))))
 494     (gnus-server-update-server (car killed))
 495     (setq gnus-server-killed-servers (cdr gnus-server-killed-servers))
 496     (gnus-server-position-point)))
 497
 498 (defun gnus-server-exit ()
 499   "Return to the group buffer."
 500   (interactive)
 501   (gnus-run-hooks 'gnus-server-exit-hook)
 502   (gnus-kill-buffer (current-buffer))
 503   (gnus-configure-windows 'group t))
 504
 505 (defun gnus-server-list-servers ()
 506   "List all available servers."
 507   (interactive)
 508   (let ((cur (gnus-server-server-name)))
 509     (gnus-server-prepare)
 510     (if cur (gnus-server-goto-server cur)
 511       (goto-char (point-max))
 512       (forward-line -1))
 513     (gnus-server-position-point)))
 514
 515 (defun gnus-server-set-status (method status)
 516   "Make METHOD have STATUS."
 517   (let ((entry (assoc method gnus-opened-servers)))
 518     (if entry
 519         (setcar (cdr entry) status)
 520       (push (list method status) gnus-opened-servers))))
 521
 522 (defun gnus-opened-servers-remove (method)
 523   "Remove METHOD from the list of opened servers."
 524   (setq gnus-opened-servers (delq (assoc method gnus-opened-servers)
 525                                   gnus-opened-servers)))
 526
 527 (defun gnus-server-open-server (server)
 528   "Force an open of SERVER."
 529   (interactive (list (gnus-server-server-name)))
 530   (let ((method (gnus-server-to-method server)))
 531     (unless method
 532       (error "No such server: %s" server))
 533     (gnus-server-set-status method 'ok)
 534     (prog1
 535         (gnus-open-server method)
 536       (gnus-server-update-server server)
 537       (gnus-server-position-point))))
 538
 539 (defun gnus-server-open-all-servers ()
 540   "Open all servers."
 541   (interactive)
 542   (dolist (server gnus-inserted-opened-servers)
 543     (gnus-server-open-server (car server))))
 544
 545 (defun gnus-server-close-server (server)
 546   "Close SERVER."
 547   (interactive (list (gnus-server-server-name)))
 548   (let ((method (gnus-server-to-method server)))
 549     (unless method
 550       (error "No such server: %s" server))
 551     (gnus-server-set-status method 'closed)
 552     (prog1
 553         (gnus-close-server method)
 554       (gnus-server-update-server server)
 555       (gnus-server-position-point))))
 556
 557 (defun gnus-server-offline-server (server)
 558   "Set SERVER to offline."
 559   (interactive (list (gnus-server-server-name)))
 560   (let ((method (gnus-server-to-method server)))
 561     (unless method
 562       (error "No such server: %s" server))
 563     (prog1
 564         (gnus-close-server method)
 565       (gnus-server-set-status method 'offline)
 566       (gnus-server-update-server server)
 567       (gnus-server-position-point))))
 568
 569 (defun gnus-server-close-all-servers ()
 570   "Close all servers."
 571   (interactive)
 572   (dolist (server gnus-inserted-opened-servers)
 573     (gnus-server-close-server (car server)))
 574   (dolist (server gnus-server-alist)
 575     (gnus-server-close-server (car server))))
 576
 577 (defun gnus-server-deny-server (server)
 578   "Make sure SERVER will never be attempted opened."
 579   (interactive (list (gnus-server-server-name)))
 580   (let ((method (gnus-server-to-method server)))
 581     (unless method
 582       (error "No such server: %s" server))
 583     (gnus-server-set-status method 'denied))
 584   (gnus-server-update-server server)
 585   (gnus-server-position-point)
 586   t)
 587
 588 (defun gnus-server-remove-denials ()
 589   "Make all denied servers into closed servers."
 590   (interactive)
 591   (dolist (server gnus-opened-servers)
 592     (when (eq (nth 1 server) 'denied)
 593       (setcar (nthcdr 1 server) 'closed)))
 594   (gnus-server-list-servers))
 595
 596 (defun gnus-server-copy-server (from to)
 597   "Copy a server definition to a new name."
 598   (interactive
 599    (list
 600     (or (gnus-server-server-name)
 601         (error "No server on the current line"))
 602     (read-string "Copy to: ")))
 603   (unless from
 604     (error "No server on current line"))
 605   (unless (and to (not (string= to "")))
 606     (error "No name to copy to"))
 607   (when (assoc to gnus-server-alist)
 608     (error "%s already exists" to))
 609   (unless (gnus-server-to-method from)
 610     (error "%s: no such server" from))
 611   (let ((to-entry (cons from (gnus-copy-sequence
 612                               (gnus-server-to-method from)))))
 613     (setcar to-entry to)
 614     (setcar (nthcdr 2 to-entry) to)
 615     (push to-entry gnus-server-killed-servers)
 616     (gnus-server-yank-server)))
 617
 618 (defun gnus-server-add-server (how where)
 619   (interactive
 620    (list (intern (gnus-completing-read "Server method"
 621                                        (mapcar 'car gnus-valid-select-methods)
 622                                        t))
 623          (read-string "Server name: ")))
 624   (when (assq where gnus-server-alist)
 625     (error "Server with that name already defined"))
 626   (push (list where how where) gnus-server-killed-servers)
 627   (gnus-server-yank-server))
 628
 629 (defun gnus-server-goto-server (server)
 630   "Jump to a server line."
 631   (interactive
 632    (list (gnus-completing-read "Goto server" (mapcar 'car gnus-server-alist) t)))
 633   (let ((to (text-property-any (point-min) (point-max)
 634                                'gnus-server (intern server))))
 635     (when to
 636       (goto-char to)
 637       (gnus-server-position-point))))
 638
 639 (defun gnus-server-edit-server (server)
 640   "Edit the server on the current line."
 641   (interactive (list (gnus-server-server-name)))
 642   (unless server
 643     (error "No server on current line"))
 644   (unless (assoc server gnus-server-alist)
 645     (error "This server can't be edited"))
 646   (let ((info (cdr (assoc server gnus-server-alist))))
 647     (gnus-close-server info)
 648     (gnus-edit-form
 649      info "Editing the server."
 650      `(lambda (form)
 651         (gnus-server-set-info ,server form)
 652         (gnus-server-list-servers)
 653         (gnus-server-position-point))
 654      'edit-server)))
 655
 656 (defun gnus-server-show-server (server)
 657   "Show the definition of the server on the current line."
 658   (interactive (list (gnus-server-server-name)))
 659   (unless server
 660     (error "No server on current line"))
 661   (let ((info (gnus-server-to-method server)))
 662     (gnus-edit-form
 663      info "Showing the server."
 664      `(lambda (form)
 665         (gnus-server-position-point))
 666      'edit-server)))
 667
 668 (defun gnus-server-scan-server (server)
 669   "Request a scan from the current server."
 670   (interactive (list (gnus-server-server-name)))
 671   (let ((method (gnus-server-to-method server)))
 672     (if (not (gnus-get-function method 'request-scan))
 673         (error "Server %s can't scan" (car method))
 674       (gnus-message 3 "Scanning %s..." server)
 675       (gnus-request-scan nil method)
 676       (gnus-message 3 "Scanning %s...done" server))))
 677
 678 (defun gnus-server-read-server-in-server-buffer (server)
 679   "Browse a server in server buffer."
 680   (interactive (list (gnus-server-server-name)))
 681   (let (gnus-server-browse-in-group-buffer)
 682     (gnus-server-read-server server)))
 683
 684 (defun gnus-server-read-server (server)
 685   "Browse a server."
 686   (interactive (list (gnus-server-server-name)))
 687   (let ((buf (current-buffer)))
 688     (prog1
 689         (gnus-browse-foreign-server server buf)
 690       (with-current-buffer buf
 691         (gnus-server-update-server (gnus-server-server-name))
 692         (gnus-server-position-point)))))
 693
 694 (defun gnus-server-pick-server (e)
 695   (interactive "e")
 696   (mouse-set-point e)
 697   (gnus-server-read-server (gnus-server-server-name)))
 698
 699 \f
 700 ;;;
 701 ;;; Browse Server Mode
 702 ;;;
 703
 704 (defcustom gnus-browse-menu-hook nil
 705   "Hook run after the creation of the browse mode menu."
 706   :group 'gnus-server
 707   :type 'hook)
 708
 709 (defcustom gnus-browse-subscribe-newsgroup-method
 710   'gnus-subscribe-alphabetically
 711   "Function(s) called when subscribing groups in the Browse Server Buffer
 712 A few pre-made functions are supplied: `gnus-subscribe-randomly'
 713 inserts new groups at the beginning of the list of groups;
 714 `gnus-subscribe-alphabetically' inserts new groups in strict
 715 alphabetic order; `gnus-subscribe-hierarchically' inserts new groups
 716 in hierarchical newsgroup order; `gnus-subscribe-interactively' asks
 717 for your decision; `gnus-subscribe-killed' kills all new groups;
 718 `gnus-subscribe-zombies' will make all new groups into zombies;
 719 `gnus-subscribe-topics' will enter groups into the topics that
 720 claim them."
 721   :version "24.1"
 722   :group 'gnus-server
 723   :type '(radio (function-item gnus-subscribe-randomly)
 724                 (function-item gnus-subscribe-alphabetically)
 725                 (function-item gnus-subscribe-hierarchically)
 726                 (function-item gnus-subscribe-interactively)
 727                 (function-item gnus-subscribe-killed)
 728                 (function-item gnus-subscribe-zombies)
 729                 (function-item gnus-subscribe-topics)
 730                 function
 731                 (repeat function)))
 732
 733 (defvar gnus-browse-mode-hook nil)
 734 (defvar gnus-browse-mode-map nil)
 735 (put 'gnus-browse-mode 'mode-class 'special)
 736
 737 (unless gnus-browse-mode-map
 738   (setq gnus-browse-mode-map (make-keymap))
 739   (suppress-keymap gnus-browse-mode-map)
 740
 741   (gnus-define-keys
 742       gnus-browse-mode-map
 743     " " gnus-browse-read-group
 744     "=" gnus-browse-select-group
 745     "n" gnus-browse-next-group
 746     "p" gnus-browse-prev-group
 747     "\177" gnus-browse-prev-group
 748     [delete] gnus-browse-prev-group
 749     "N" gnus-browse-next-group
 750     "P" gnus-browse-prev-group
 751     "\M-n" gnus-browse-next-group
 752     "\M-p" gnus-browse-prev-group
 753     "\r" gnus-browse-select-group
 754     "u" gnus-browse-unsubscribe-current-group
 755     "l" gnus-browse-exit
 756     "L" gnus-browse-exit
 757     "q" gnus-browse-exit
 758     "Q" gnus-browse-exit
 759     "d" gnus-browse-describe-group
 760     [delete] gnus-browse-delete-group
 761     "\C-c\C-c" gnus-browse-exit
 762     "?" gnus-browse-describe-briefly
 763
 764     "\C-c\C-i" gnus-info-find-node
 765     "\C-c\C-b" gnus-bug))
 766
 767 (defun gnus-browse-make-menu-bar ()
 768   (gnus-turn-off-edit-menu 'browse)
 769   (unless (boundp 'gnus-browse-menu)
 770     (easy-menu-define
 771      gnus-browse-menu gnus-browse-mode-map ""
 772      '("Browse"
 773        ["Subscribe" gnus-browse-unsubscribe-current-group t]
 774        ["Read" gnus-browse-read-group t]
 775        ["Select" gnus-browse-select-group t]
 776        ["Describe" gnus-browse-describe-group t]
 777        ["Next" gnus-browse-next-group t]
 778        ["Prev" gnus-browse-prev-group t]
 779        ["Exit" gnus-browse-exit t]))
 780     (gnus-run-hooks 'gnus-browse-menu-hook)))
 781
 782 (defvar gnus-browse-current-method nil)
 783 (defvar gnus-browse-return-buffer nil)
 784
 785 (defvar gnus-browse-buffer "*Gnus Browse Server*")
 786
 787 (defun gnus-browse-foreign-server (server &optional return-buffer)
 788   "Browse the server SERVER."
 789   (setq gnus-browse-current-method (gnus-server-to-method server))
 790   (setq gnus-browse-return-buffer return-buffer)
 791   (let* ((method gnus-browse-current-method)
 792          (orig-select-method gnus-select-method)
 793          (gnus-select-method method)
 794          groups group)
 795     (gnus-message 5 "Connecting to %s..." (nth 1 method))
 796     (cond
 797      ((not (gnus-check-server method))
 798       (gnus-message
 799        1 "Unable to contact server %s: %s" (nth 1 method)
 800        (gnus-status-message method))
 801       nil)
 802      ((not
 803        (prog2
 804            (gnus-message 6 "Reading active file...")
 805            (gnus-request-list method)
 806          (gnus-message 6 "Reading active file...done")))
 807       (gnus-message
 808        1 "Couldn't request list: %s" (gnus-status-message method))
 809       nil)
 810      (t
 811       (with-current-buffer nntp-server-buffer
 812         (let ((cur (current-buffer)))
 813           (goto-char (point-min))
 814          (unless (or (null gnus-ignored-newsgroups)
 815                      (string= gnus-ignored-newsgroups ""))
 816             (delete-matching-lines gnus-ignored-newsgroups))
 817           ;; We treat NNTP as a special case to avoid problems with
 818           ;; garbage group names like `"foo' that appear in some badly
 819           ;; managed active files. -jh.
 820           (if (eq (car method) 'nntp)
 821               (while (not (eobp))
 822                 (ignore-errors
 823                   (push (cons
 824                          (string-as-unibyte
 825                           (buffer-substring
 826                            (point)
 827                            (progn
 828                              (skip-chars-forward "^ \t")
 829                              (point))))
 830                          (let ((last (read cur)))
 831                            (cons (read cur) last)))
 832                         groups))
 833                 (forward-line))
 834             (while (not (eobp))
 835               (ignore-errors
 836                 (push (cons
 837                        (string-as-unibyte
 838                         (if (eq (char-after) ?\")
 839                             (read cur)
 840                           (let ((p (point)) (name ""))
 841                             (skip-chars-forward "^ \t\\\\")
 842                             (setq name (buffer-substring p (point)))
 843                             (while (eq (char-after) ?\\)
 844                               (setq p (1+ (point)))
 845                               (forward-char 2)
 846                               (skip-chars-forward "^ \t\\\\")
 847                               (setq name (concat name (buffer-substring
 848                                                        p (point)))))
 849                             name)))
 850                        (let ((last (read cur)))
 851                          (cons (read cur) last)))
 852                       groups))
 853               (forward-line)))))
 854       (setq groups (sort groups
 855                          (lambda (l1 l2)
 856                            (string< (car l1) (car l2)))))
 857       (if gnus-server-browse-in-group-buffer
 858           (let* ((gnus-select-method orig-select-method)
 859                  (gnus-group-listed-groups
 860                   (mapcar (lambda (group)
 861                             (let ((name
 862                                    (gnus-group-prefixed-name
 863                                     (car group) method)))
 864                               (gnus-set-active name (cdr group))
 865                               name))
 866                           groups)))
 867             (gnus-configure-windows 'group)
 868             (funcall gnus-group-prepare-function
 869                      gnus-level-killed 'ignore 1 'ignore))
 870         (gnus-get-buffer-create gnus-browse-buffer)
 871         (gnus-configure-windows 'browse)
 872         (buffer-disable-undo)
 873         (let ((buffer-read-only nil))
 874           (erase-buffer))
 875         (gnus-browse-mode)
 876         (setq mode-line-buffer-identification
 877               (list
 878                (format
 879                 "Gnus: %%b {%s:%s}" (car method) (cadr method))))
 880         (let ((buffer-read-only nil)
 881               name
 882               (prefix (let ((gnus-select-method orig-select-method))
 883                         (gnus-group-prefixed-name "" method))))
 884           (while (setq group (pop groups))
 885             (add-text-properties
 886              (point)
 887              (prog1 (1+ (point))
 888                (insert
 889                 (format "%c%7d: %s\n"
 890                         (let ((level
 891                                (if (string= prefix "")
 892                                    (gnus-group-level (setq name (car group)))
 893                                  (gnus-group-level
 894                                   (concat prefix (setq name (car group)))))))
 895                           (cond
 896                            ((<= level gnus-level-subscribed) ? )
 897                            ((<= level gnus-level-unsubscribed) ?U)
 898                            ((= level gnus-level-zombie) ?Z)
 899                            (t ?K)))
 900                         (max 0 (- (1+ (cddr group)) (cadr group)))
 901                         ;; Don't decode if name is ASCII
 902                         (if (eq (detect-coding-string name t) 'undecided)
 903                             name
 904                           (decode-coding-string
 905                            name
 906                            (inline (gnus-group-name-charset method name)))))))
 907              (list 'gnus-group name)
 908              )))
 909         (switch-to-buffer (current-buffer)))
 910       (goto-char (point-min))
 911       (gnus-group-position-point)
 912       (gnus-message 5 "Connecting to %s...done" (nth 1 method))
 913       t))))
 914
 915 (define-derived-mode gnus-browse-mode fundamental-mode "Browse Server"
 916   "Major mode for browsing a foreign server.
 917
 918 All normal editing commands are switched off.
 919
 920 \\<gnus-browse-mode-map>
 921 The only things you can do in this buffer is
 922
 923 1) `\\[gnus-browse-unsubscribe-current-group]' to subscribe to a group.
 924 The group will be inserted into the group buffer upon exit from this
 925 buffer.
 926
 927 2) `\\[gnus-browse-read-group]' to read a group ephemerally.
 928
 929 3) `\\[gnus-browse-exit]' to return to the group buffer."
 930   (when (gnus-visual-p 'browse-menu 'menu)
 931     (gnus-browse-make-menu-bar))
 932   (gnus-simplify-mode-line)
 933   (setq mode-line-process nil)
 934   (buffer-disable-undo)
 935   (setq truncate-lines t)
 936   (gnus-set-default-directory)
 937   (setq buffer-read-only t))
 938
 939 (defun gnus-browse-read-group (&optional no-article number)
 940   "Enter the group at the current line.
 941 If NUMBER, fetch this number of articles."
 942   (interactive "P")
 943   (let ((group (gnus-browse-group-name)))
 944     (if (or (not (gnus-get-info group))
 945             (gnus-ephemeral-group-p group))
 946         (unless (gnus-group-read-ephemeral-group
 947                  group gnus-browse-current-method nil
 948                  (cons (current-buffer) 'browse)
 949                  nil nil nil number)
 950           (error "Couldn't enter %s" group))
 951       (unless (gnus-group-read-group nil no-article group)
 952         (error "Couldn't enter %s" group)))))
 953
 954 (defun gnus-browse-select-group (&optional number)
 955   "Select the current group.
 956 If NUMBER, fetch this number of articles."
 957   (interactive "P")
 958   (gnus-browse-read-group 'no number))
 959
 960 (defun gnus-browse-next-group (n)
 961   "Go to the next group."
 962   (interactive "p")
 963   (prog1
 964       (forward-line n)
 965     (gnus-group-position-point)))
 966
 967 (defun gnus-browse-prev-group (n)
 968   "Go to the next group."
 969   (interactive "p")
 970   (gnus-browse-next-group (- n)))
 971
 972 (defun gnus-browse-unsubscribe-current-group (arg)
 973   "(Un)subscribe to the next ARG groups.
 974 The variable `gnus-browse-subscribe-newsgroup-method' determines
 975 how new groups will be entered into the group buffer."
 976   (interactive "p")
 977   (when (eobp)
 978     (error "No group at current line"))
 979   (let ((ward (if (< arg 0) -1 1))
 980         (arg (abs arg)))
 981     (while (and (> arg 0)
 982                 (not (eobp))
 983                 (gnus-browse-unsubscribe-group)
 984                 (zerop (gnus-browse-next-group ward)))
 985       (decf arg))
 986     (gnus-group-position-point)
 987     (when (/= 0 arg)
 988       (gnus-message 7 "No more newsgroups"))
 989     arg))
 990
 991 (defun gnus-browse-group-name ()
 992   (save-excursion
 993     (beginning-of-line)
 994     (let ((name (get-text-property (point) 'gnus-group)))
 995       (when (re-search-forward ": \\(.*\\)$" (point-at-eol) t)
 996         (concat (gnus-method-to-server-name gnus-browse-current-method) ":"
 997                 (or name
 998                     (match-string-no-properties 1)))))))
 999
1000 (defun gnus-browse-describe-group (group)
1001   "Describe the current group."
1002   (interactive (list (gnus-browse-group-name)))
1003   (gnus-group-describe-group nil group))
1004
1005 (defun gnus-browse-delete-group (group force)
1006   "Delete the current group.  Only meaningful with editable groups.
1007 If FORCE (the prefix) is non-nil, all the articles in the group will
1008 be deleted.  This is \"deleted\" as in \"removed forever from the face
1009 of the Earth\".  There is no undo.  The user will be prompted before
1010 doing the deletion."
1011   (interactive (list (gnus-browse-group-name)
1012                      current-prefix-arg))
1013   (gnus-group-delete-group group force))
1014
1015 (defun gnus-browse-unsubscribe-group ()
1016   "Toggle subscription of the current group in the browse buffer."
1017   (let ((sub nil)
1018         (buffer-read-only nil)
1019         group)
1020     (save-excursion
1021       (beginning-of-line)
1022       ;; If this group it killed, then we want to subscribe it.
1023       (unless (eq (char-after) ? )
1024         (setq sub t))
1025       (setq group (gnus-browse-group-name))
1026       (when (gnus-server-equal gnus-browse-current-method "native")
1027         (setq group (gnus-group-real-name group)))
1028       (if sub
1029           (progn
1030             ;; Make sure the group has been properly removed before we
1031             ;; subscribe to it.
1032             (if (gnus-ephemeral-group-p group)
1033                 (gnus-kill-ephemeral-group group))
1034             (let ((entry (gnus-group-entry group)))
1035               (if entry
1036                   ;; Just change the subscription level if it is an
1037                   ;; unsubscribed group.
1038                   (gnus-group-change-level entry
1039                                            gnus-level-default-subscribed)
1040                 ;; If it is a killed group or a zombie, feed it to the
1041                 ;; mechanism for new group subscription.
1042                 (gnus-call-subscribe-functions
1043                  gnus-browse-subscribe-newsgroup-method
1044                  group)
1045                 (gnus-request-update-group-status group 'subscribe)))
1046             (delete-char 1)
1047             (insert (let ((lvl (gnus-group-level group)))
1048                       (cond
1049                        ((< lvl gnus-level-unsubscribed) ? )
1050                        ((< lvl gnus-level-zombie) ?U)
1051                        ((< lvl gnus-level-killed) ?Z)
1052                        (t ?K)))))
1053         (gnus-group-change-level
1054          group gnus-level-unsubscribed gnus-level-default-subscribed)
1055         (delete-char 1)
1056         (insert ?U)))
1057     t))
1058
1059 (defun gnus-browse-exit ()
1060   "Quit browsing and return to the group buffer."
1061   (interactive)
1062   (when (derived-mode-p 'gnus-browse-mode)
1063     (gnus-kill-buffer (current-buffer)))
1064   ;; Insert the newly subscribed groups in the group buffer.
1065   (with-current-buffer gnus-group-buffer
1066     (gnus-group-list-groups nil))
1067   (if gnus-browse-return-buffer
1068       (gnus-configure-windows 'server 'force)
1069     (gnus-configure-windows 'group 'force)))
1070
1071 (defun gnus-browse-describe-briefly ()
1072   "Give a one line description of the group mode commands."
1073   (interactive)
1074   (gnus-message 6 "%s"
1075                 (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")))
1076
1077 (defun gnus-server-regenerate-server ()
1078   "Issue a command to the server to regenerate all its data structures."
1079   (interactive)
1080   (let ((server (gnus-server-server-name)))
1081     (unless server
1082       (error "No server on the current line"))
1083     (condition-case ()
1084         (gnus-get-function (gnus-server-to-method server)
1085                            'request-regenerate)
1086       (error
1087         (error "This back end doesn't support regeneration")))
1088     (gnus-message 5 "Requesting regeneration of %s..." server)
1089     (unless (gnus-open-server server)
1090       (error "Couldn't open server"))
1091     (if (gnus-request-regenerate server)
1092         (gnus-message 5 "Requesting regeneration of %s...done" server)
1093       (gnus-message 5 "Couldn't regenerate %s" server))))
1094
1095
1096 ;;;
1097 ;;; Server compaction. -- dvl
1098 ;;;
1099
1100 ;; #### FIXME: this function currently fails to update the Group buffer's
1101 ;; #### appearance.
1102 (defun gnus-server-compact-server ()
1103   "Issue a command to the server to compact all its groups.
1104
1105 Note: currently only implemented in nnml."
1106   (interactive)
1107   (let ((server (gnus-server-server-name)))
1108     (unless server
1109       (error "No server on the current line"))
1110     (condition-case ()
1111         (gnus-get-function (gnus-server-to-method server)
1112                            'request-compact)
1113       (error
1114        (error "This back end doesn't support compaction")))
1115     (gnus-message 5 "\
1116 Requesting compaction of %s... (this may take a long time)"
1117                   server)
1118     (unless (gnus-open-server server)
1119       (error "Couldn't open server"))
1120     (if (not (gnus-request-compact server))
1121         (gnus-message 5 "Couldn't compact %s" server)
1122       (gnus-message 5 "Requesting compaction of %s...done" server)
1123       ;; Invalidate the original article buffer which might be out of date.
1124       ;; #### NOTE: Yes, this might be a bit rude, but since compaction
1125       ;; #### will not happen very often, I think this is acceptable.
1126       (let ((original (get-buffer gnus-original-article-buffer)))
1127         (and original (gnus-kill-buffer original))))))
1128
1129 (defun gnus-server-toggle-cloud-server ()
1130   "Make the server under point be replicated in the Emacs Cloud."
1131   (interactive)
1132   (let ((server (gnus-server-server-name)))
1133     (unless server
1134       (error "No server on the current line"))
1135
1136     (unless (gnus-method-option-p server 'cloud)
1137       (error "The server under point doesn't support cloudiness"))
1138
1139     (if (gnus-cloud-server-p server)
1140         (setq gnus-cloud-covered-servers
1141               (delete server gnus-cloud-covered-servers))
1142       (push server gnus-cloud-covered-servers))
1143
1144     (gnus-server-update-server server)
1145     (gnus-message 1 (if (gnus-cloud-server-p server)
1146                         "Replication of %s in the cloud will start"
1147                       "Replication of %s in the cloud will stop")
1148                   server)))
1149
1150 (defun gnus-server-toggle-cloud-method-server ()
1151   "Set the server under point to host the Emacs Cloud."
1152   (interactive)
1153   (let ((server (gnus-server-server-name)))
1154     (unless server
1155       (error "No server on the current line"))
1156     (unless (gnus-cloud-host-acceptable-method-p server)
1157       (error "The server under point can't host the Emacs Cloud"))
1158
1159     (custom-set-variables '(gnus-cloud-method server))
1160     (when (gnus-yes-or-no-p (format "Upload Cloud data to %S now? " server))
1161       (gnus-message 1 "Uploading all data to Emacs Cloud server %S" server)
1162       (gnus-cloud-upload-data t))))
1163
1164 (provide 'gnus-srvr)
1165
1166 ;;; gnus-srvr.el ends here