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

   1 ;;; gnus-srvr.el --- virtual server support for Gnus
   2
   3 ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
   4 ;;   2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
   5
   6 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   7 ;; Keywords: news
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile (require 'cl))
  29
  30 (require 'gnus)
  31 (require 'gnus-spec)
  32 (require 'gnus-group)
  33 (require 'gnus-int)
  34 (require 'gnus-range)
  35
  36 (defcustom gnus-server-mode-hook nil
  37   "Hook run in `gnus-server-mode' buffers."
  38   :group 'gnus-server
  39   :type 'hook)
  40
  41 (defcustom gnus-server-exit-hook nil
  42   "Hook run when exiting the server buffer."
  43   :group 'gnus-server
  44   :type 'hook)
  45
  46 (defcustom gnus-server-line-format "     {%(%h:%w%)} %s%a\n"
  47   "Format of server lines.
  48 It works along the same lines as a normal formatting string,
  49 with some simple extensions.
  50
  51 The following specs are understood:
  52
  53 %h back end
  54 %n name
  55 %w address
  56 %s status
  57 %a agent covered
  58
  59 General format specifiers can also be used.
  60 See Info node `(gnus)Formatting Variables'."
  61   :link '(custom-manual "(gnus)Formatting Variables")
  62   :group 'gnus-server-visual
  63   :type 'string)
  64
  65 (defcustom gnus-server-mode-line-format "Gnus: %%b"
  66   "The format specification for the server mode line."
  67   :group 'gnus-server-visual
  68   :type 'string)
  69
  70 (defcustom gnus-server-browse-in-group-buffer nil
  71   "Whether server browsing should take place in the group buffer.
  72 If nil, a faster, but more primitive, buffer is used instead."
  73   :version "22.1"
  74   :group 'gnus-server-visual
  75   :type 'boolean)
  76
  77 ;;; Internal variables.
  78
  79 (defvar gnus-inserted-opened-servers nil)
  80
  81 (defvar gnus-server-line-format-alist
  82   `((?h gnus-tmp-how ?s)
  83     (?n gnus-tmp-name ?s)
  84     (?w gnus-tmp-where ?s)
  85     (?s gnus-tmp-status ?s)
  86     (?a gnus-tmp-agent ?s)))
  87
  88 (defvar gnus-server-mode-line-format-alist
  89   `((?S gnus-tmp-news-server ?s)
  90     (?M gnus-tmp-news-method ?s)
  91     (?u gnus-tmp-user-defined ?s)))
  92
  93 (defvar gnus-server-line-format-spec nil)
  94 (defvar gnus-server-mode-line-format-spec nil)
  95 (defvar gnus-server-killed-servers nil)
  96
  97 (defvar gnus-server-mode-map)
  98
  99 (defvar gnus-server-menu-hook nil
 100   "*Hook run after the creation of the server mode menu.")
 101
 102 (defun gnus-server-make-menu-bar ()
 103   (gnus-turn-off-edit-menu 'server)
 104   (unless (boundp 'gnus-server-server-menu)
 105     (easy-menu-define
 106      gnus-server-server-menu gnus-server-mode-map ""
 107      '("Server"
 108        ["Add..." gnus-server-add-server t]
 109        ["Browse" gnus-server-read-server t]
 110        ["Scan" gnus-server-scan-server t]
 111        ["List" gnus-server-list-servers t]
 112        ["Kill" gnus-server-kill-server t]
 113        ["Yank" gnus-server-yank-server t]
 114        ["Copy" gnus-server-copy-server t]
 115        ["Edit" gnus-server-edit-server t]
 116        ["Regenerate" gnus-server-regenerate-server t]
 117        ["Compact" gnus-server-compact-server t]
 118        ["Exit" gnus-server-exit t]))
 119
 120     (easy-menu-define
 121      gnus-server-connections-menu gnus-server-mode-map ""
 122      '("Connections"
 123        ["Open" gnus-server-open-server t]
 124        ["Close" gnus-server-close-server t]
 125        ["Offline" gnus-server-offline-server t]
 126        ["Deny" gnus-server-deny-server t]
 127        "---"
 128        ["Open All" gnus-server-open-all-servers t]
 129        ["Close All" gnus-server-close-all-servers t]
 130        ["Reset All" gnus-server-remove-denials t]))
 131
 132     (gnus-run-hooks 'gnus-server-menu-hook)))
 133
 134 (defvar gnus-server-mode-map nil)
 135 (put 'gnus-server-mode 'mode-class 'special)
 136
 137 (unless gnus-server-mode-map
 138   (setq gnus-server-mode-map (make-sparse-keymap))
 139   (suppress-keymap gnus-server-mode-map)
 140
 141   (gnus-define-keys gnus-server-mode-map
 142     " " gnus-server-read-server-in-server-buffer
 143     "\r" gnus-server-read-server
 144     gnus-mouse-2 gnus-server-pick-server
 145     "q" gnus-server-exit
 146     "l" gnus-server-list-servers
 147     "k" gnus-server-kill-server
 148     "y" gnus-server-yank-server
 149     "c" gnus-server-copy-server
 150     "a" gnus-server-add-server
 151     "e" gnus-server-edit-server
 152     "s" gnus-server-scan-server
 153
 154     "O" gnus-server-open-server
 155     "\M-o" gnus-server-open-all-servers
 156     "C" gnus-server-close-server
 157     "\M-c" gnus-server-close-all-servers
 158     "D" gnus-server-deny-server
 159     "L" gnus-server-offline-server
 160     "R" gnus-server-remove-denials
 161
 162     "n" next-line
 163     "p" previous-line
 164
 165     "g" gnus-server-regenerate-server
 166
 167     "z" gnus-server-compact-server
 168
 169     "\C-c\C-i" gnus-info-find-node
 170     "\C-c\C-b" gnus-bug))
 171
 172 (defface gnus-server-agent
 173   '((((class color) (background light)) (:foreground "PaleTurquoise" :bold t))
 174     (((class color) (background dark)) (:foreground "PaleTurquoise" :bold t))
 175     (t (:bold t)))
 176   "Face used for displaying AGENTIZED servers"
 177   :group 'gnus-server-visual)
 178 ;; backward-compatibility alias
 179 (put 'gnus-server-agent-face 'face-alias 'gnus-server-agent)
 180 (put 'gnus-server-agent-face 'obsolete-face "22.1")
 181
 182 (defface gnus-server-opened
 183   '((((class color) (background light)) (:foreground "Green3" :bold t))
 184     (((class color) (background dark)) (:foreground "Green1" :bold t))
 185     (t (:bold t)))
 186   "Face used for displaying OPENED servers"
 187   :group 'gnus-server-visual)
 188 ;; backward-compatibility alias
 189 (put 'gnus-server-opened-face 'face-alias 'gnus-server-opened)
 190 (put 'gnus-server-opened-face 'obsolete-face "22.1")
 191
 192 (defface gnus-server-closed
 193   '((((class color) (background light)) (:foreground "Steel Blue" :italic t))
 194     (((class color) (background dark))
 195      (:foreground "LightBlue" :italic t))
 196     (t (:italic t)))
 197   "Face used for displaying CLOSED servers"
 198   :group 'gnus-server-visual)
 199 ;; backward-compatibility alias
 200 (put 'gnus-server-closed-face 'face-alias 'gnus-server-closed)
 201 (put 'gnus-server-closed-face 'obsolete-face "22.1")
 202
 203 (defface gnus-server-denied
 204   '((((class color) (background light)) (:foreground "Red" :bold t))
 205     (((class color) (background dark)) (:foreground "Pink" :bold t))
 206     (t (:inverse-video t :bold t)))
 207   "Face used for displaying DENIED servers"
 208   :group 'gnus-server-visual)
 209 ;; backward-compatibility alias
 210 (put 'gnus-server-denied-face 'face-alias 'gnus-server-denied)
 211 (put 'gnus-server-denied-face 'obsolete-face "22.1")
 212
 213 (defface gnus-server-offline
 214   '((((class color) (background light)) (:foreground "Orange" :bold t))
 215     (((class color) (background dark)) (:foreground "Yellow" :bold t))
 216     (t (:inverse-video t :bold t)))
 217   "Face used for displaying OFFLINE servers"
 218   :group 'gnus-server-visual)
 219 ;; backward-compatibility alias
 220 (put 'gnus-server-offline-face 'face-alias 'gnus-server-offline)
 221 (put 'gnus-server-offline-face 'obsolete-face "22.1")
 222
 223 (defvar gnus-server-font-lock-keywords
 224   '(("(\\(agent\\))" 1 'gnus-server-agent)
 225     ("(\\(opened\\))" 1 'gnus-server-opened)
 226     ("(\\(closed\\))" 1 'gnus-server-closed)
 227     ("(\\(offline\\))" 1 'gnus-server-offline)
 228     ("(\\(denied\\))" 1 'gnus-server-denied)))
 229
 230 (defun gnus-server-mode ()
 231   "Major mode for listing and editing servers.
 232
 233 All normal editing commands are switched off.
 234 \\<gnus-server-mode-map>
 235 For more in-depth information on this mode, read the manual
 236 \(`\\[gnus-info-find-node]').
 237
 238 The following commands are available:
 239
 240 \\{gnus-server-mode-map}"
 241   (interactive)
 242   (when (gnus-visual-p 'server-menu 'menu)
 243     (gnus-server-make-menu-bar))
 244   (kill-all-local-variables)
 245   (gnus-simplify-mode-line)
 246   (setq major-mode 'gnus-server-mode)
 247   (setq mode-name "Server")
 248   (gnus-set-default-directory)
 249   (setq mode-line-process nil)
 250   (use-local-map gnus-server-mode-map)
 251   (buffer-disable-undo)
 252   (setq truncate-lines t)
 253   (setq buffer-read-only t)
 254   (if (featurep 'xemacs)
 255       (put 'gnus-server-mode 'font-lock-defaults '(gnus-server-font-lock-keywords t))
 256     (set (make-local-variable 'font-lock-defaults)
 257          '(gnus-server-font-lock-keywords t)))
 258   (gnus-run-mode-hooks 'gnus-server-mode-hook))
 259
 260 (defun gnus-server-insert-server-line (gnus-tmp-name method)
 261   (let* ((gnus-tmp-how (car method))
 262          (gnus-tmp-where (nth 1 method))
 263          (elem (assoc method gnus-opened-servers))
 264          (gnus-tmp-status
 265           (cond
 266            ((eq (nth 1 elem) 'denied) "(denied)")
 267            ((eq (nth 1 elem) 'offline) "(offline)")
 268            (t
 269             (condition-case nil
 270                 (if (or (gnus-server-opened method)
 271                         (eq (nth 1 elem) 'ok))
 272                     "(opened)"
 273                   "(closed)")
 274               ((error) "(error)")))))
 275          (gnus-tmp-agent (if (and gnus-agent
 276                                   (gnus-agent-method-p method))
 277                              " (agent)"
 278                            "")))
 279     (beginning-of-line)
 280     (gnus-add-text-properties
 281      (point)
 282      (prog1 (1+ (point))