cgit.sxemacs.org Git - gnus/blob - lisp/gnus-srvr.el

   1 ;;; gnus-srvr.el --- virtual server support for Gnus
   2 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001
   3 ;;        Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;; Keywords: news
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (eval-when-compile (require 'cl))
  30
  31 (require 'gnus)
  32 (require 'gnus-spec)
  33 (require 'gnus-group)
  34 (require 'gnus-int)
  35 (require 'gnus-range)
  36
  37 (defcustom gnus-server-mode-hook nil
  38   "Hook run in `gnus-server-mode' buffers."
  39   :group 'gnus-server
  40   :type 'hook)
  41
  42 (defcustom gnus-server-exit-hook nil
  43   "Hook run when exiting the server buffer."
  44   :group 'gnus-server
  45   :type 'hook)
  46
  47 (defcustom gnus-server-line-format "     {%(%h:%w%)} %s%a\n"
  48   "Format of server lines.
  49 It works along the same lines as a normal formatting string,
  50 with some simple extensions.
  51
  52 The following specs are understood:
  53
  54 %h backend
  55 %n name
  56 %w address
  57 %s status
  58 %a agent covered"
  59   :group 'gnus-server-visual
  60   :type 'string)
  61
  62 (defcustom gnus-server-mode-line-format "Gnus: %%b"
  63   "The format specification for the server mode line."
  64   :group 'gnus-server-visual
  65   :type 'string)
  66
  67 (defcustom gnus-server-browse-in-group-buffer nil
  68   "Whether browse server in group buffer."
  69   :group 'gnus-server-visual
  70   :type 'string)
  71
  72 ;;; Internal variables.
  73
  74 (defvar gnus-inserted-opened-servers nil)
  75
  76 (defvar gnus-server-line-format-alist
  77   `((?h gnus-tmp-how ?s)
  78     (?n gnus-tmp-name ?s)
  79     (?w gnus-tmp-where ?s)
  80     (?s gnus-tmp-status ?s)
  81     (?a gnus-tmp-agent ?s)))
  82
  83 (defvar gnus-server-mode-line-format-alist
  84   `((?S gnus-tmp-news-server ?s)
  85     (?M gnus-tmp-news-method ?s)
  86     (?u gnus-tmp-user-defined ?s)))
  87
  88 (defvar gnus-server-line-format-spec nil)
  89 (defvar gnus-server-mode-line-format-spec nil)
  90 (defvar gnus-server-killed-servers nil)
  91
  92 (defvar gnus-server-mode-map)
  93
  94 (defvar gnus-server-menu-hook nil
  95   "*Hook run after the creation of the server mode menu.")
  96
  97 (defun gnus-server-make-menu-bar ()
  98   (gnus-turn-off-edit-menu 'server)
  99   (unless (boundp 'gnus-server-server-menu)
 100     (easy-menu-define
 101      gnus-server-server-menu gnus-server-mode-map ""
 102      '("Server"
 103        ["Add" gnus-server-add-server t]
 104        ["Browse" gnus-server-read-server t]
 105        ["Scan" gnus-server-scan-server t]
 106        ["List" gnus-server-list-servers t]
 107        ["Kill" gnus-server-kill-server t]
 108        ["Yank" gnus-server-yank-server t]
 109        ["Copy" gnus-server-copy-server t]
 110        ["Edit" gnus-server-edit-server t]
 111        ["Regenerate" gnus-server-regenerate-server t]
 112        ["Exit" gnus-server-exit t]))
 113
 114     (easy-menu-define
 115      gnus-server-connections-menu gnus-server-mode-map ""
 116      '("Connections"
 117        ["Open" gnus-server-open-server t]
 118        ["Close" gnus-server-close-server t]
 119        ["Deny" gnus-server-deny-server t]
 120        "---"
 121        ["Open All" gnus-server-open-all-servers t]
 122        ["Close All" gnus-server-close-all-servers t]
 123        ["Reset All" gnus-server-remove-denials t]))
 124
 125     (gnus-run-hooks 'gnus-server-menu-hook)))
 126
 127 (defvar gnus-server-mode-map nil)
 128 (put 'gnus-server-mode 'mode-class 'special)
 129
 130 (unless gnus-server-mode-map
 131   (setq gnus-server-mode-map (make-sparse-keymap))
 132   (suppress-keymap gnus-server-mode-map)
 133
 134   (gnus-define-keys gnus-server-mode-map
 135     " " gnus-server-read-server-in-server-buffer
 136     "\r" gnus-server-read-server
 137     gnus-mouse-2 gnus-server-pick-server
 138     "q" gnus-server-exit
 139     "l" gnus-server-list-servers
 140     "k" gnus-server-kill-server
 141     "y" gnus-server-yank-server
 142     "c" gnus-server-copy-server
 143     "a" gnus-server-add-server
 144     "e" gnus-server-edit-server
 145     "s" gnus-server-scan-server
 146
 147     "O" gnus-server-open-server
 148     "\M-o" gnus-server-open-all-servers
 149     "C" gnus-server-close-server
 150     "\M-c" gnus-server-close-all-servers
 151     "D" gnus-server-deny-server
 152     "R" gnus-server-remove-denials
 153
 154     "n" next-line
 155     "p" previous-line
 156
 157     "g" gnus-server-regenerate-server
 158
 159     "\C-c\C-i" gnus-info-find-node
 160     "\C-c\C-b" gnus-bug))
 161
 162 (defface gnus-server-agent-face
 163   '((((class color) (background light)) (:foreground "PaleTurquoise" :bold t))
 164     (((class color) (background dark)) (:foreground "PaleTurquoise" :bold t))
 165     (t (:bold t)))
 166   "Face used for displaying AGENTIZED servers"
 167   :group 'gnus-server-visual)
 168
 169 (defface gnus-server-opened-face
 170   '((((class color) (background light)) (:foreground "Green3" :bold t))
 171     (((class color) (background dark)) (:foreground "Green1" :bold t))
 172     (t (:bold t)))
 173   "Face used for displaying OPENED servers"
 174   :group 'gnus-server-visual)
 175
 176 (defface gnus-server-closed-face
 177   '((((class color) (background light)) (:foreground "Steel Blue" :italic t))
 178     (((class color) (background dark))
 179      (:foreground "Light Steel Blue" :italic t))
 180     (t (:italic t)))
 181   "Face used for displaying CLOSED servers"
 182   :group 'gnus-server-visual)
 183
 184 (defface gnus-server-denied-face
 185   '((((class color) (background light)) (:foreground "Red" :bold t))
 186     (((class color) (background dark)) (:foreground "Pink" :bold t))
 187     (t (:inverse-video t :bold t)))
 188   "Face used for displaying DENIED servers"
 189   :group 'gnus-server-visual)
 190
 191 (defcustom gnus-server-agent-face 'gnus-server-agent-face
 192   "Face name to use on AGENTIZED servers."
 193   :group 'gnus-server-visual
 194   :type 'face)
 195
 196 (defcustom gnus-server-opened-face 'gnus-server-opened-face
 197   "Face name to use on OPENED servers."
 198   :group 'gnus-server-visual
 199   :type 'face)
 200
 201 (defcustom gnus-server-closed-face 'gnus-server-closed-face
 202   "Face name to use on CLOSED servers."
 203   :group 'gnus-server-visual
 204   :type 'face)
 205
 206 (defcustom gnus-server-denied-face 'gnus-server-denied-face
 207   "Face name to use on DENIED servers."
 208   :group 'gnus-server-visual
 209   :type 'face)
 210
 211 (defvar gnus-server-font-lock-keywords
 212   (list
 213    '("(\\(agent\\))" 1 gnus-server-agent-face)
 214    '("(\\(opened\\))" 1 gnus-server-opened-face)
 215    '("(\\(closed\\))" 1 gnus-server-closed-face)
 216    '("(\\(denied\\))" 1 gnus-server-denied-face)))
 217
 218 (defun gnus-server-mode ()
 219   "Major mode for listing and editing servers.
 220
 221 All normal editing commands are switched off.
 222 \\<gnus-server-mode-map>
 223 For more in-depth information on this mode, read the manual
 224 \(`\\[gnus-info-find-node]').
 225
 226 The following commands are available:
 227
 228 \\{gnus-server-mode-map}"
 229   (interactive)
 230   (when (gnus-visual-p 'server-menu 'menu)
 231     (gnus-server-make-menu-bar))
 232   (kill-all-local-variables)
 233   (gnus-simplify-mode-line)
 234   (setq major-mode 'gnus-server-mode)
 235   (setq mode-name "Server")
 236   (gnus-set-default-directory)
 237   (setq mode-line-process nil)
 238   (use-local-map gnus-server-mode-map)
 239   (buffer-disable-undo)
 240   (setq truncate-lines t)
 241   (setq buffer-read-only t)
 242   (if (featurep 'xemacs)
 243       (put 'gnus-server-mode 'font-lock-defaults '(gnus-server-font-lock-keywords t))
 244     (set (make-local-variable 'font-lock-defaults)
 245          '(gnus-server-font-lock-keywords t)))
 246   (gnus-run-hooks 'gnus-server-mode-hook))
 247
 248 (defun gnus-server-insert-server-line (gnus-tmp-name method)
 249   (let* ((gnus-tmp-how (car method))
 250          (gnus-tmp-where (nth 1 method))
 251          (elem (assoc method gnus-opened-servers))
 252          (gnus-tmp-status
 253           (if (eq (nth 1 elem) 'denied)
 254               "(denied)"
 255             (condition-case nil
 256                 (if (or (gnus-server-opened method)
 257                         (eq (nth 1 elem) 'ok))
 258                     "(opened)"
 259                   "(closed)")
 260               ((error) "(error)"))))
 261          (gnus-tmp-agent (if (and gnus-agent
 262                                   (member method
 263                                           gnus-agent-covered-methods))
 264                              " (agent)"
 265                            "")))
 266     (beginning-of-line)
 267     (gnus-add-text-properties
 268      (point)
 269      (prog1 (1+ (point))
 270        ;; Insert the text.
 271        (eval gnus-server-line-format-spec))
 272      (list 'gnus-server (intern gnus-tmp-name)))))
 273
 274 (defun gnus-enter-server-buffer ()
 275   "Set up the server buffer."
 276   (gnus-server-setup-buffer)
 277   (gnus-configure-windows 'server)
 278   (gnus-server-prepare))
 279
 280 (defun gnus-server-setup-buffer ()
 281   "Initialize the server buffer."
 282   (unless (get-buffer gnus-server-buffer)
 283     (save-excursion
 284       (set-buffer (gnus-get-buffer-create gnus-server-buffer))
 285       (gnus-server-mode)
 286       (when gnus-carpal
 287         (gnus-carpal-setup-buffer 'server)))))
 288
 289 (defun gnus-server-prepare ()
 290   (gnus-set-format 'server-mode)
 291   (gnus-set-format 'server t)
 292   (let ((alist gnus-server-alist)
 293         (buffer-read-only nil)
 294         (opened gnus-opened-servers)
 295         done server op-ser)
 296     (erase-buffer)
 297     (setq gnus-inserted-opened-servers nil)
 298     ;; First we do the real list of servers.
 299     (while alist
 300       (unless (member (cdar alist) done)
 301         (push (cdar alist) done)
 302         (cdr (setq server (pop alist)))
 303         (when (and server (car server) (cdr server))
 304           (gnus-server-insert-server-line (car server) (cdr server))))
 305       (when (member (cdar alist) done)
 306         (pop alist)))
 307     ;; Then we insert the list of servers that have been opened in
 308     ;; this session.
 309     (while opened
 310       (when (and (not (member (caar opened) done))
 311                  ;; Just ignore ephemeral servers.
 312                  (not (member (caar opened) gnus-ephemeral-servers)))
 313         (push (caar opened) done)
 314         (gnus-server-insert-server-line
 315          (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened))))
 316          (caar opened))
 317         (push (list op-ser (caar opened)) gnus-inserted-opened-servers))
 318       (setq opened (cdr opened))))
 319   (goto-char (point-min))
 320   (gnus-server-position-point))
 321
 322 (defun gnus-server-server-name ()
 323   (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server)))
 324     (and server (symbol-name server))))
 325
 326 (defalias 'gnus-server-position-point 'gnus-goto-colon)
 327
 328 (defconst gnus-server-edit-buffer "*Gnus edit server*")
 329
 330 (defun gnus-server-update-server (server)
 331   (save-excursion
 332     (set-buffer gnus-server-buffer)
 333     (let* ((buffer-read-only nil)
 334            (entry (assoc server gnus-server-alist))
 335            (oentry (assoc (gnus-server-to-method server)
 336                           gnus-opened-servers)))
 337       (when entry
 338         (gnus-dribble-enter
 339          (concat "(gnus-server-set-info \"" server "\" '"
 340                  (prin1-to-string (cdr entry)) ")\n")))
 341       (when (or entry oentry)
 342         ;; Buffer may be narrowed.
 343         (save-restriction
 344           (widen)
 345           (when (gnus-server-goto-server server)
 346             (gnus-delete-line))
 347           (if entry
 348               (gnus-server-insert-server-line (car entry) (cdr entry))
 349             (gnus-server-insert-server-line
 350              (format "%s:%s" (caar oentry) (nth 1 (car oentry)))
 351              (car oentry)))
 352           (gnus-server-position-point))))))
 353
 354 (defun gnus-server-set-info (server info)
 355   ;; Enter a select method into the virtual server alist.
 356   (when (and server info)
 357     (gnus-dribble-enter
 358      (concat "(gnus-server-set-info \"" server "\" '"
 359              (prin1-to-string info) ")"))
 360     (let* ((server (nth 1 info))
 361            (entry (assoc server gnus-server-alist)))
 362       (if entry (setcdr entry info)
 363         (setq gnus-server-alist
 364               (nconc gnus-server-alist (list (cons server info))))))))
 365
 366 ;;; Interactive server functions.
 367
 368 (defun gnus-server-kill-server (server)
 369   "Kill the server on the current line."
 370   (interactive (list (gnus-server-server-name)))
 371   (unless (gnus-server-goto-server server)
 372     (if server (error "No such server: %s" server)
 373       (error "No server on the current line")))
 374   (unless (assoc server gnus-server-alist)
 375     (error "Read-only server %s" server))
 376   (gnus-dribble-touch)
 377   (let ((buffer-read-only nil))
 378     (gnus-delete-line))
 379   (push (assoc server gnus-server-alist) gnus-server-killed-servers)
 380   (setq gnus-server-alist (delq (car gnus-server-killed-servers)
 381                                 gnus-server-alist))
 382   (let ((groups (gnus-groups-from-server server)))
 383     (when (and groups
 384                (gnus-yes-or-no-p
 385                 (format "Kill all %s groups from this server? "
 386                         (length groups))))
 387       (dolist (group groups)
 388         (setq gnus-newsrc-alist
 389               (delq (assoc group gnus-newsrc-alist)
 390                     gnus-newsrc-alist))
 391         (when gnus-group-change-level-function
 392           (funcall gnus-group-change-level-function
 393                    group gnus-level-killed 3)))))
 394   (gnus-server-position-point))
 395
 396 (defun gnus-server-yank-server ()
 397   "Yank the previously killed server."
 398   (interactive)
 399   (unless gnus-server-killed-servers
 400     (error "No killed servers to be yanked"))
 401   (let ((alist gnus-server-alist)
 402         (server (gnus-server-server-name))
 403         (killed (car gnus-server-killed-servers)))
 404     (if (not server)
 405         (setq gnus-server-alist (nconc gnus-server-alist (list killed)))
 406       (if (string= server (caar gnus-server-alist))
 407           (push killed gnus-server-alist)
 408         (while (and (cdr alist)
 409                     (not (string= server (caadr alist))))
 410           (setq alist (cdr alist)))
 411         (if alist
 412             (setcdr alist (cons killed (cdr alist)))
 413           (setq gnus-server-alist (list killed)))))
 414     (gnus-server-update-server (car killed))
 415     (setq gnus-server-killed-servers (cdr gnus-server-killed-servers))
 416     (gnus-server-position-point)))
 417
 418 (defun gnus-server-exit ()
 419   "Return to the group buffer."
 420   (interactive)
 421   (gnus-run-hooks 'gnus-server-exit-hook)
 422   (kill-buffer (current-buffer))
 423   (gnus-configure-windows 'group t))
 424
 425 (defun gnus-server-list-servers ()
 426   "List all available servers."
 427   (interactive)
 428   (let ((cur (gnus-server-server-name)))
 429     (gnus-server-prepare)
 430     (if cur (gnus-server-goto-server cur)
 431       (goto-char (point-max))
 432       (forward-line -1))