lisp/gnus/gnus-srvr.el

   1 ;;; gnus-srvr.el --- virtual server support for Gnus
   2
   3 ;; Copyright (C) 1995-2017 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 <https://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 "Server %s must be deleted from your configuration files"
 456            server))
 457   (gnus-dribble-touch)
 458   (let ((buffer-read-only nil))
 459     (gnus-delete-line))
 460   (push (assoc server gnus-server-alist) gnus-server-killed-servers)
 461   (setq gnus-server-alist (delq (car gnus-server-killed-servers)
 462                                 gnus-server-alist))
 463   (let ((groups (gnus-groups-from-server server)))
 464     (when (and groups
 465                (gnus-yes-or-no-p
 466                 (format "Kill all %s groups from this server? "
 467                         (length groups))))
 468       (dolist (group groups)
 469         (setq gnus-newsrc-alist
 470               (delq (assoc group gnus-newsrc-alist)
 471                     gnus-newsrc-alist))
 472         (when gnus-group-change-level-function
 473           (funcall gnus-group-change-level-function
 474                    group gnus-level-killed 3)))))
 475   (gnus-server-position-point))
 476
 477 (defun gnus-server-yank-server ()
 478   "Yank the previously killed server."
 479   (interactive)
 480   (unless gnus-server-killed-servers
 481     (error "No killed servers to be yanked"))
 482   (let ((alist gnus-server-alist)
 483         (server (gnus-server-server-name))
 484         (killed (car gnus-server-killed-servers)))
 485     (if (not server)
 486         (setq gnus-server-alist (nconc gnus-server-alist (list killed)))
 487       (if (string= server (caar gnus-server-alist))
 488           (push killed gnus-server-alist)
 489         (while (and (cdr alist)
 490                     (not (string= server (caadr alist))))
 491           (setq alist (cdr alist)))
 492         (if alist
 493             (setcdr alist (cons killed (cdr alist)))
 494           (setq gnus-server-alist (list killed)))))
 495     (gnus-server-update-server (car killed))
 496     (setq gnus-server-killed-servers (cdr gnus-server-killed-servers))
 497     (gnus-server-position-point)))
 498
 499 (defun gnus-server-exit ()
 500   "Return to the group buffer."
 501   (interactive)
 502   (gnus-run-hooks 'gnus-server-exit-hook)
 503   (gnus-kill-buffer (current-buffer))
 504   (gnus-configure-windows 'group t))
 505
 506 (defun gnus-server-list-servers ()
 507   "List all available servers."
 508   (interactive)
 509   (let ((cur (gnus-server-server-name)))
 510     (gnus-server-prepare)
 511     (if cur (gnus-server-goto-server cur)
 512       (goto-char (point-max))
 513       (forward-line -1))
 514     (gnus-server-position-point)))
 515
 516 (defun gnus-server-set-status (method status)
 517   "Make METHOD have STATUS."
 518   (let ((entry (assoc method gnus-opened-servers)))
 519     (if entry
 520         (setcar (cdr entry) status)
 521       (push (list method status) gnus-opened-servers))))
 522
 523 (defun gnus-opened-servers-remove (method)
 524   "Remove METHOD from the list of opened servers."
 525   (setq gnus-opened-servers (delq (assoc method gnus-opened-servers)
 526                                   gnus-opened-servers)))
 527
 528 (defun gnus-server-open-server (server)
 529   "Force an open of SERVER."
 530   (interactive (list (gnus-server-server-name)))
 531   (let ((method (gnus-server-to-method server)))
 532     (unless method
 533       (error "No such server: %s" server))
 534     (gnus-server-set-status method 'ok)
 535     (prog1
 536         (gnus-open-server method)
 537       (gnus-server-update-server server)
 538       (gnus-server-position-point))))
 539
 540 (defun gnus-server-open-all-servers ()
 541   "Open all servers."
 542   (interactive)
 543   (dolist (server gnus-inserted-opened-servers)
 544     (gnus-server-open-server (car server))))
 545
 546 (defun gnus-server-close-server (server)
 547   "Close SERVER."
 548   (interactive (list (gnus-server-server-name)))
 549   (let ((method (gnus-server-to-method server)))
 550     (unless method
 551       (error "No such server: %s" server))
 552     (gnus-server-set-status method 'closed)
 553     (prog1
 554         (gnus-close-server method)
 555       (gnus-server-update-server server)
 556       (gnus-server-position-point))))
 557
 558 (defun gnus-server-offline-server (server)
 559   "Set SERVER to offline."
 560   (interactive (list (gnus-server-server-name)))
 561   (let ((method (gnus-server-to-method server)))
 562     (unless method
 563       (error "No such server: %s" server))
 564     (prog1
 565         (gnus-close-server method)
 566       (gnus-server-set-status method 'offline)
 567       (gnus-server-update-server server)
 568       (gnus-server-position-point))))
 569
 570 (defun gnus-server-close-all-servers ()
 571   "Close all servers."
 572   (interactive)
 573   (dolist (server gnus-inserted-opened-servers)
 574     (gnus-server-close-server (car server)))
 575   (dolist (server gnus-server-alist)
 576     (gnus-server-close-server (car server))))
 577
 578 (defun gnus-server-deny-server (server)
 579   "Make sure SERVER will never be attempted opened."
 580   (interactive (list (gnus-server-server-name)))
 581   (let ((method (gnus-server-to-method server)))
 582     (unless method
 583       (error "No such server: %s" server))
 584     (gnus-server-set-status method 'denied))
 585   (gnus-server-update-server server)
 586   (gnus-server-position-point)
 587   t)
 588
 589 (defun gnus-server-remove-denials ()
 590   "Make all denied servers into closed servers."
 591   (interactive)
 592   (dolist (server gnus-opened-servers)
 593     (when (eq (nth 1 server) 'denied)
 594       (setcar (nthcdr 1 server) 'closed)))
 595   (gnus-server-list-servers))
 596
 597 (defun gnus-server-copy-server (from to)
 598   "Copy a server definition to a new name."
 599   (interactive
 600    (list
 601     (or (gnus-server-server-name)
 602         (error "No server on the current line"))
 603     (read-string "Copy to: ")))
 604   (unless from
 605     (error "No server on current line"))
 606   (unless (and to (not (string= to "")))
 607     (error "No name to copy to"))
 608   (when (assoc to gnus-server-alist)
 609     (error "%s already exists" to))
 610   (unless (gnus-server-to-method from)
 611     (error "%s: no such server" from))
 612   (let ((to-entry (cons from (copy-tree
 613                               (gnus-server-to-method from)))))
 614     (setcar to-entry to)
 615     (setcar (nthcdr 2 to-entry) to)
 616     (push to-entry gnus-server-killed-servers)
 617     (gnus-server-yank-server)))
 618
 619 (defun gnus-server-add-server (how where)
 620   (interactive
 621    (list (intern (gnus-completing-read "Server method"
 622                                        (mapcar 'car gnus-valid-select-methods)
 623                                        t))
 624          (read-string "Server name: ")))
 625   (when (assq where gnus-server-alist)
 626     (error "Server with that name already defined"))
 627   (push (list where how where) gnus-server-killed-servers)
 628   (gnus-server-yank-server))
 629
 630 (defun gnus-server-goto-server (server)
 631   "Jump to a server line."
 632   (interactive
 633    (list (gnus-completing-read "Goto server" (mapcar 'car gnus-server-alist) t)))
 634   (let ((to (text-property-any (point-min) (point-max)
 635                                'gnus-server (intern server))))
 636     (when to
 637       (goto-char to)
 638       (gnus-server-position-point))))
 639
 640 (defun gnus-server-edit-server (server)
 641   "Edit the server on the current line."
 642   (interactive (list (gnus-server-server-name)))
 643   (unless server
 644     (error "No server on current line"))
 645   (unless (assoc server gnus-server-alist)
 646     (error "Server %s must be edited in your configuration files"
 647            server))
 648   (let ((info (cdr (assoc server gnus-server-alist))))
 649     (gnus-close-server info)
 650     (gnus-edit-form
 651      info "Editing the server."
 652      `(lambda (form)
 653         (gnus-server-set-info ,server form)
 654         (gnus-server-list-servers)
 655         (gnus-server-position-point))
 656      'edit-server)))
 657
 658 (defun gnus-server-show-server (server)
 659   "Show the definition of the server on the current line."
 660   (interactive (list (gnus-server-server-name)))
 661   (unless server
 662     (error "No server on current line"))
 663   (let ((info (gnus-server-to-method server)))
 664     (gnus-edit-form
 665      info "Showing the server."
 666      `(lambda (form)
 667         (gnus-server-position-point))
 668      'edit-server)))
 669
 670 (defun gnus-server-scan-server (server)
 671   "Request a scan from the current server."
 672   (interactive (list (gnus-server-server-name)))
 673   (let ((method (gnus-server-to-method server)))
 674     (if (not (gnus-get-function method 'request-scan))
 675         (error "Server %s can't scan" (car method))
 676       (gnus-message 3 "Scanning %s..." server)
 677       (gnus-request-scan nil method)
 678       (gnus-message 3 "Scanning %s...done" server))))
 679
 680 (defun gnus-server-read-server-in-server-buffer (server)
 681   "Browse a server in server buffer."
 682   (interactive (list (gnus-server-server-name)))
 683   (let (gnus-server-browse-in-group-buffer)
 684     (gnus-server-read-server server)))
 685
 686 (defun gnus-server-read-server (server)
 687   "Browse a server."
 688   (interactive (list (gnus-server-server-name)))
 689   (let ((buf (current-buffer)))
 690     (prog1
 691         (gnus-browse-foreign-server server buf)
 692       (with-current-buffer buf
 693         (gnus-server-update-server (gnus-server-server-name))
 694         (gnus-server-position-point)))))
 695
 696 (defun gnus-server-pick-server (e)
 697   (interactive "e")
 698   (mouse-set-point e)
 699   (gnus-server-read-server (gnus-server-server-name)))
 700
 701 \f
 702 ;;;
 703 ;;; Browse Server Mode
 704 ;;;
 705
 706 (defcustom gnus-browse-menu-hook nil
 707   "Hook run after the creation of the browse mode menu."
 708   :group 'gnus-server
 709   :type 'hook)
 710
 711 (defcustom gnus-browse-subscribe-newsgroup-method
 712   'gnus-subscribe-alphabetically
 713   "Function(s) called when subscribing groups in the Browse Server Buffer
 714 A few pre-made functions are supplied: `gnus-subscribe-randomly'
 715 inserts new groups at the beginning of the list of groups;
 716 `gnus-subscribe-alphabetically' inserts new groups in strict
 717 alphabetic order; `gnus-subscribe-hierarchically' inserts new groups
 718 in hierarchical newsgroup order; `gnus-subscribe-interactively' asks
 719 for your decision; `gnus-subscribe-killed' kills all new groups;
 720 `gnus-subscribe-zombies' will make all new groups into zombies;
 721 `gnus-subscribe-topics' will enter groups into the topics that
 722 claim them."
 723   :version "24.1"
 724   :group 'gnus-server
 725   :type '(radio (function-item gnus-subscribe-randomly)
 726                 (function-item gnus-subscribe-alphabetically)
 727                 (function-item gnus-subscribe-hierarchically)
 728                 (function-item gnus-subscribe-interactively)
 729                 (function-item gnus-subscribe-killed)
 730                 (function-item gnus-subscribe-zombies)
 731                 (function-item gnus-subscribe-topics)
 732                 function
 733                 (repeat function)))
 734
 735 (defvar gnus-browse-mode-hook nil)
 736 (defvar gnus-browse-mode-map nil)
 737 (put 'gnus-browse-mode 'mode-class 'special)
 738
 739 (unless gnus-browse-mode-map
 740   (setq gnus-browse-mode-map (make-keymap))
 741   (suppress-keymap gnus-browse-mode-map)
 742
 743   (gnus-define-keys
 744       gnus-browse-mode-map
 745     " " gnus-browse-read-group
 746     "=" gnus-browse-select-group
 747     "n" gnus-browse-next-group
 748     "p" gnus-browse-prev-group
 749     "\177" gnus-browse-prev-group
 750     [delete] gnus-browse-prev-group
 751     "N" gnus-browse-next-group
 752     "P" gnus-browse-prev-group
 753     "\M-n" gnus-browse-next-group
 754     "\M-p" gnus-browse-prev-group
 755     "\r" gnus-browse-select-group
 756     "u" gnus-browse-unsubscribe-current-group
 757     "l" gnus-browse-exit
 758     "L" gnus-browse-exit
 759     "q" gnus-browse-exit
 760     "Q" gnus-browse-exit
 761     "d" gnus-browse-describe-group
 762     [delete] gnus-browse-delete-group
 763     "\C-c\C-c" gnus-browse-exit
 764     "?" gnus-browse-describe-briefly
 765
 766     "\C-c\C-i" gnus-info-find-node
 767     "\C-c\C-b" gnus-bug))
 768
 769 (defun gnus-browse-make-menu-bar ()
 770   (gnus-turn-off-edit-menu 'browse)
 771   (unless (boundp 'gnus-browse-menu)
 772     (easy-menu-define
 773      gnus-browse-menu gnus-browse-mode-map ""
 774      '("Browse"
 775        ["Subscribe" gnus-browse-unsubscribe-current-group t]
 776        ["Read" gnus-browse-read-group t]
 777        ["Select" gnus-browse-select-group t]
 778        ["Describe" gnus-browse-describe-group t]
 779        ["Next" gnus-browse-next-group t]
 780        ["Prev" gnus-browse-prev-group t]
 781        ["Exit" gnus-browse-exit t]))
 782     (gnus-run-hooks 'gnus-browse-menu-hook)))
 783
 784 (defvar gnus-browse-current-method nil)
 785 (defvar gnus-browse-return-buffer nil)
 786
 787 (defvar gnus-browse-buffer "*Gnus Browse Server*")
 788
 789 (defun gnus-browse-foreign-server (server &optional return-buffer)
 790   "Browse the server SERVER."
 791   (setq gnus-browse-current-method (gnus-server-to-method server))
 792   (setq gnus-browse-return-buffer return-buffer)
 793   (let* ((method gnus-browse-current-method)
 794          (orig-select-method gnus-select-method)
 795          (gnus-select-method method)
 796          groups group)
 797     (gnus-message 5 "Connecting to %s..." (nth 1 method))
 798     (cond
 799      ((not (gnus-check-server method))
 800       (gnus-message
 801        1 "Unable to contact server %s: %s" (nth 1 method)
 802        (gnus-status-message method))
 803       nil)
 804      ((not
 805        (prog2
 806            (gnus-message 6 "Reading active file...")
 807            (gnus-request-list method)
 808          (gnus-message 6 "Reading active file...done")))
 809       (gnus-message
 810        1 "Couldn't request list: %s" (gnus-status-message method))
 811       nil)
 812      (t
 813       (with-current-buffer nntp-server-buffer
 814         (let ((cur (current-buffer)))
 815           (goto-char (point-min))
 816          (unless (or (null gnus-ignored-newsgroups)
 817                      (string= gnus-ignored-newsgroups ""))
 818             (delete-matching-lines gnus-ignored-newsgroups))
 819           ;; We treat NNTP as a special case to avoid problems with
 820           ;; garbage group names like `"foo' that appear in some badly
 821           ;; managed active files. -jh.
 822           (if (eq (car method) 'nntp)
 823               (while (not (eobp))
 824                 (ignore-errors
 825                   (push (cons
 826                          (string-as-unibyte
 827                           (buffer-substring
 828                            (point)
 829                            (progn
 830                              (skip-chars-forward "^ \t")
 831                              (point))))
 832                          (let ((last (read cur)))
 833                            (cons (read cur) last)))
 834                         groups))
 835                 (forward-line))
 836             (while (not (eobp))
 837               (ignore-errors
 838                 (push (cons
 839                        (string-as-unibyte
 840                         (if (eq (char-after) ?\")
 841                             (read cur)
 842                           (let ((p (point)) (name ""))
 843                             (skip-chars-forward "^ \t\\\\")
 844                             (setq name (buffer-substring p (point)))
 845                             (while (eq (char-after) ?\\)
 846                               (setq p (1+ (point)))
 847                               (forward-char 2)
 848                               (skip-chars-forward "^ \t\\\\")
 849                               (setq name (concat name (buffer-substring
 850                                                        p (point)))))
 851                             name)))
 852                        (let ((last (read cur)))
 853                          (cons (read cur) last)))
 854                       groups))
 855               (forward-line)))))
 856       (setq groups (sort groups
 857                          (lambda (l1 l2)
 858                            (string< (car l1) (car l2)))))
 859       (if gnus-server-browse-in-group-buffer
 860           (let* ((gnus-select-method orig-select-method)
 861                  (gnus-group-listed-groups
 862                   (mapcar (lambda (group)
 863                             (let ((name
 864                                    (gnus-group-prefixed-name
 865                                     (car group) method)))
 866                               (gnus-set-active name (cdr group))
 867                               name))
 868                           groups)))
 869             (gnus-configure-windows 'group)
 870             (funcall gnus-group-prepare-function
 871                      gnus-level-killed 'ignore 1 'ignore))
 872         (gnus-get-buffer-create gnus-browse-buffer)
 873         (gnus-configure-windows 'browse)
 874         (buffer-disable-undo)
 875         (let ((buffer-read-only nil))
 876           (erase-buffer))
 877         (gnus-browse-mode)
 878         (setq mode-line-buffer-identification
 879               (list
 880                (format
 881                 "Gnus: %%b {%s:%s}" (car method) (cadr method))))
 882         (let ((buffer-read-only nil)
 883               name
 884               (prefix (let ((gnus-select-method orig-select-method))
 885                         (gnus-group-prefixed-name "" method))))
 886           (while (setq group (pop groups))
 887             (add-text-properties
 888              (point)
 889              (prog1 (1+ (point))
 890                (insert
 891                 (format "%c%7d: %s\n"
 892                         (let ((level
 893                                (if (string= prefix "")
 894                                    (gnus-group-level (setq name (car group)))
 895                                  (gnus-group-level
 896                                   (concat prefix (setq name (car group)))))))
 897                           (cond
 898                            ((<= level gnus-level-subscribed) ? )
 899                            ((<= level gnus-level-unsubscribed) ?U)
 900                            ((= level gnus-level-zombie) ?Z)
 901                            (t ?K)))
 902                         (max 0 (- (1+ (cddr group)) (cadr group)))
 903                         ;; Don't decode if name is ASCII
 904                         (if (eq (detect-coding-string name t) 'undecided)
 905                             name
 906                           (decode-coding-string
 907                            name
 908                            (inline (gnus-group-name-charset method name)))))))
 909              (list 'gnus-group name)
 910              )))
 911         (switch-to-buffer (current-buffer)))
 912       (goto-char (point-min))
 913       (gnus-group-position-point)
 914       (gnus-message 5 "Connecting to %s...done" (nth 1 method))
 915       t))))
 916
 917 (define-derived-mode gnus-browse-mode fundamental-mode "Browse Server"
 918   "Major mode for browsing a foreign server.
 919
 920 All normal editing commands are switched off.
 921
 922 \\<gnus-browse-mode-map>
 923 The only things you can do in this buffer is
 924
 925 1) `\\[gnus-browse-unsubscribe-current-group]' to subscribe to a group.
 926 The group will be inserted into the group buffer upon exit from this
 927 buffer.
 928
 929 2) `\\[gnus-browse-read-group]' to read a group ephemerally.
 930
 931 3) `\\[gnus-browse-exit]' to return to the group buffer."
 932   (when (gnus-visual-p 'browse-menu 'menu)
 933     (gnus-browse-make-menu-bar))
 934   (gnus-simplify-mode-line)
 935   (setq mode-line-process nil)
 936   (buffer-disable-undo)
 937   (setq truncate-lines t)
 938   (gnus-set-default-directory)
 939   (setq buffer-read-only t))
 940
 941 (defun gnus-browse-read-group (&optional no-article number)
 942   "Enter the group at the current line.
 943 If NUMBER, fetch this number of articles."
 944   (interactive "P")
 945   (let ((group (gnus-browse-group-name)))
 946     (if (or (not (gnus-get-info group))
 947             (gnus-ephemeral-group-p group))
 948         (unless (gnus-group-read-ephemeral-group
 949                  group gnus-browse-current-method nil
 950                  (cons (current-buffer) 'browse)
 951                  nil nil nil number)
 952           (error "Couldn't enter %s" group))
 953       (unless (gnus-group-read-group nil no-article group)
 954         (error "Couldn't enter %s" group)))))
 955
 956 (defun gnus-browse-select-group (&optional number)
 957   "Select the current group.
 958 If NUMBER, fetch this number of articles."
 959   (interactive "P")
 960   (gnus-browse-read-group 'no number))
 961
 962 (defun gnus-browse-next-group (n)
 963   "Go to the next group."
 964   (interactive "p")
 965   (prog1
 966       (forward-line n)
 967     (gnus-group-position-point)))
 968
 969 (defun gnus-browse-prev-group (n)
 970   "Go to the next group."
 971   (interactive "p")
 972   (gnus-browse-next-group (- n)))
 973
 974 (defun gnus-browse-unsubscribe-current-group (arg)
 975   "(Un)subscribe to the next ARG groups.
 976 The variable `gnus-browse-subscribe-newsgroup-method' determines
 977 how new groups will be entered into the group buffer."
 978   (interactive "p")
 979   (when (eobp)
 980     (error "No group at current line"))
 981   (let ((ward (if (< arg 0) -1 1))
 982         (arg (abs arg)))
 983     (while (and (> arg 0)
 984                 (not (eobp))
 985                 (gnus-browse-unsubscribe-group)
 986                 (zerop (gnus-browse-next-group ward)))
 987       (decf arg))
 988     (gnus-group-position-point)
 989     (when (/= 0 arg)
 990       (gnus-message 7 "No more newsgroups"))
 991     arg))
 992
 993 (defun gnus-browse-group-name ()
 994   (save-excursion
 995     (beginning-of-line)
 996     (let ((name (get-text-property (point) 'gnus-group)))
 997       (when (re-search-forward ": \\(.*\\)$" (point-at-eol) t)
 998         (concat (gnus-method-to-server-name gnus-browse-current-method) ":"
 999                 (or name
1000                     (match-string-no-properties 1)))))))
1001
1002 (defun gnus-browse-describe-group (group)
1003   "Describe the current group."
1004   (interactive (list (gnus-browse-group-name)))
1005   (gnus-group-describe-group nil group))
1006
1007 (defun gnus-browse-delete-group (group force)
1008   "Delete the current group.  Only meaningful with editable groups.
1009 If FORCE (the prefix) is non-nil, all the articles in the group will
1010 be deleted.  This is \"deleted\" as in \"removed forever from the face
1011 of the Earth\".  There is no undo.  The user will be prompted before
1012 doing the deletion."
1013   (interactive (list (gnus-browse-group-name)
1014                      current-prefix-arg))
1015   (gnus-group-delete-group group force))
1016
1017 (defun gnus-browse-unsubscribe-group ()
1018   "Toggle subscription of the current group in the browse buffer."
1019   (let ((sub nil)
1020         (buffer-read-only nil)
1021         group)
1022     (save-excursion
1023       (beginning-of-line)
1024       ;; If this group it killed, then we want to subscribe it.
1025       (unless (eq (char-after) ? )
1026         (setq sub t))
1027       (setq group (gnus-browse-group-name))
1028       (when (gnus-server-equal gnus-browse-current-method "native")
1029         (setq group (gnus-group-real-name group)))
1030       (if sub
1031           (progn
1032             ;; Make sure the group has been properly removed before we
1033             ;; subscribe to it.
1034             (if (gnus-ephemeral-group-p group)
1035                 (gnus-kill-ephemeral-group group))
1036             (let ((entry (gnus-group-entry group)))
1037               (if entry
1038                   ;; Just change the subscription level if it is an
1039                   ;; unsubscribed group.
1040                   (gnus-group-change-level entry
1041                                            gnus-level-default-subscribed)
1042                 ;; If it is a killed group or a zombie, feed it to the
1043                 ;; mechanism for new group subscription.
1044                 (gnus-call-subscribe-functions
1045                  gnus-browse-subscribe-newsgroup-method
1046                  group)
1047                 (gnus-request-update-group-status group 'subscribe)))
1048             (delete-char 1)
1049             (insert (let ((lvl (gnus-group-level group)))
1050                       (cond
1051                        ((< lvl gnus-level-unsubscribed) ? )
1052                        ((< lvl gnus-level-zombie) ?U)
1053                        ((< lvl gnus-level-killed) ?Z)
1054                        (t ?K)))))
1055         (gnus-group-change-level
1056          group gnus-level-unsubscribed gnus-level-default-subscribed)
1057         (delete-char 1)
1058         (insert ?U)))
1059     t))
1060
1061 (defun gnus-browse-exit ()
1062   "Quit browsing and return to the group buffer."
1063   (interactive)
1064   (when (derived-mode-p 'gnus-browse-mode)
1065     (gnus-kill-buffer (current-buffer)))
1066   ;; Insert the newly subscribed groups in the group buffer.
1067   (with-current-buffer gnus-group-buffer
1068     (gnus-group-list-groups nil))
1069   (if gnus-browse-return-buffer
1070       (gnus-configure-windows 'server 'force)
1071     (gnus-configure-windows 'group 'force)))
1072
1073 (defun gnus-browse-describe-briefly ()
1074   "Give a one line description of the group mode commands."
1075   (interactive)
1076   (gnus-message 6 "%s"
1077                 (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")))
1078
1079 (defun gnus-server-regenerate-server ()
1080   "Issue a command to the server to regenerate all its data structures."
1081   (interactive)
1082   (let ((server (gnus-server-server-name)))
1083     (unless server
1084       (error "No server on the current line"))
1085     (condition-case ()
1086         (gnus-get-function (gnus-server-to-method server)
1087                            'request-regenerate)
1088       (error
1089         (error "This back end doesn't support regeneration")))
1090     (gnus-message 5 "Requesting regeneration of %s..." server)
1091     (unless (gnus-open-server server)
1092       (error "Couldn't open server"))
1093     (if (gnus-request-regenerate server)
1094         (gnus-message 5 "Requesting regeneration of %s...done" server)
1095       (gnus-message 5 "Couldn't regenerate %s" server))))
1096
1097
1098 ;;;
1099 ;;; Server compaction. -- dvl
1100 ;;;
1101
1102 ;; #### FIXME: this function currently fails to update the Group buffer's
1103 ;; #### appearance.
1104 (defun gnus-server-compact-server ()
1105   "Issue a command to the server to compact all its groups.
1106
1107 Note: currently only implemented in nnml."
1108   (interactive)
1109   (let ((server (gnus-server-server-name)))
1110     (unless server
1111       (error "No server on the current line"))
1112     (condition-case ()
1113         (gnus-get-function (gnus-server-to-method server)
1114                            'request-compact)
1115       (error
1116        (error "This back end doesn't support compaction")))
1117     (gnus-message 5 "\
1118 Requesting compaction of %s... (this may take a long time)"
1119                   server)
1120     (unless (gnus-open-server server)
1121       (error "Couldn't open server"))
1122     (if (not (gnus-request-compact server))
1123         (gnus-message 5 "Couldn't compact %s" server)
1124       (gnus-message 5 "Requesting compaction of %s...done" server)
1125       ;; Invalidate the original article buffer which might be out of date.
1126       ;; #### NOTE: Yes, this might be a bit rude, but since compaction
1127       ;; #### will not happen very often, I think this is acceptable.
1128       (let ((original (get-buffer gnus-original-article-buffer)))
1129         (and original (gnus-kill-buffer original))))))
1130
1131 (defun gnus-server-toggle-cloud-server ()
1132   "Make the server under point be replicated in the Emacs Cloud."
1133   (interactive)
1134   (let ((server (gnus-server-server-name)))
1135     (unless server
1136       (error "No server on the current line"))
1137
1138     (unless (gnus-method-option-p server 'cloud)
1139       (error "The server under point doesn't support cloudiness"))
1140
1141     (if (gnus-cloud-server-p server)
1142         (setq gnus-cloud-covered-servers
1143               (delete server gnus-cloud-covered-servers))
1144       (push server gnus-cloud-covered-servers))
1145
1146     (gnus-server-update-server server)
1147     (gnus-message 1 (if (gnus-cloud-server-p server)
1148                         "Replication of %s in the cloud will start"
1149                       "Replication of %s in the cloud will stop")
1150                   server)))
1151
1152 (defun gnus-server-toggle-cloud-method-server ()
1153   "Set the server under point to host the Emacs Cloud."
1154   (interactive)
1155   (let ((server (gnus-server-server-name)))
1156     (unless server
1157       (error "No server on the current line"))
1158     (unless (gnus-cloud-host-acceptable-method-p server)
1159       (error "The server under point can't host the Emacs Cloud"))
1160
1161     (when (not (string-equal gnus-cloud-method server))
1162       (customize-set-variable 'gnus-cloud-method server)
1163       ;; Note we can't use `Custom-save' here.
1164       (when (gnus-yes-or-no-p
1165              (format "The new cloud host server is %S now. Save it? " server))
1166         (customize-save-variable 'gnus-cloud-method server)))
1167     (when (gnus-yes-or-no-p (format "Upload Cloud data to %S now? " server))
1168       (gnus-message 1 "Uploading all data to Emacs Cloud server %S" server)
1169       (gnus-cloud-upload-data t))))
1170
1171 (provide 'gnus-srvr)
1172
1173 ;;; gnus-srvr.el ends here