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-start)
  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 back end
  55 %n name
  56 %w address
  57 %s status
  58 %a agent covered
  59
  60 General format specifiers can also be used.
  61 See Info node `(gnus)Formatting Variables'."
  62   :link '(custom-manual "(gnus)Formatting Variables")
  63   :group 'gnus-server-visual
  64   :type 'string)
  65
  66 (defcustom gnus-server-mode-line-format "Gnus: %%b"
  67   "The format specification for the server mode line."
  68   :group 'gnus-server-visual
  69   :type 'string)
  70
  71 (defcustom gnus-server-browse-in-group-buffer nil
  72   "Whether server browsing should take place in the group buffer.
  73 If nil, a faster, but more primitive, buffer is used instead."
  74   :version "22.1"
  75   :group 'gnus-server-visual
  76   :type 'boolean)
  77
  78 ;;; Internal variables.
  79
  80 (defvar gnus-inserted-opened-servers nil)
  81
  82 (defvar gnus-server-line-format-alist
  83   `((?h gnus-tmp-how ?s)
  84     (?n gnus-tmp-name ?s)
  85     (?w gnus-tmp-where ?s)
  86     (?s gnus-tmp-status ?s)
  87     (?a gnus-tmp-agent ?s)))
  88
  89 (defvar gnus-server-mode-line-format-alist
  90   `((?S gnus-tmp-news-server ?s)
  91     (?M gnus-tmp-news-method ?s)
  92     (?u gnus-tmp-user-defined ?s)))
  93
  94 (defvar gnus-server-line-format-spec nil)
  95 (defvar gnus-server-mode-line-format-spec nil)
  96 (defvar gnus-server-killed-servers nil)
  97
  98 (defvar gnus-server-mode-map)
  99
 100 (defvar gnus-server-menu-hook nil
 101   "*Hook run after the creation of the server mode menu.")
 102
 103 (defun gnus-server-make-menu-bar ()
 104   (gnus-turn-off-edit-menu 'server)
 105   (unless (boundp 'gnus-server-server-menu)
 106     (easy-menu-define
 107      gnus-server-server-menu gnus-server-mode-map ""
 108      '("Server"
 109        ["Add..." gnus-server-add-server t]
 110        ["Browse" gnus-server-read-server t]
 111        ["Scan" gnus-server-scan-server t]
 112        ["List" gnus-server-list-servers t]
 113        ["Kill" gnus-server-kill-server t]
 114        ["Yank" gnus-server-yank-server t]
 115        ["Copy" gnus-server-copy-server t]
 116        ["Edit" gnus-server-edit-server t]
 117        ["Regenerate" gnus-server-regenerate-server t]
 118        ["Compact" gnus-server-compact-server t]
 119        ["Exit" gnus-server-exit t]))
 120
 121     (easy-menu-define
 122      gnus-server-connections-menu gnus-server-mode-map ""
 123      '("Connections"
 124        ["Open" gnus-server-open-server t]
 125        ["Close" gnus-server-close-server t]
 126        ["Offline" gnus-server-offline-server t]
 127        ["Deny" gnus-server-deny-server t]
 128        "---"
 129        ["Open All" gnus-server-open-all-servers t]
 130        ["Close All" gnus-server-close-all-servers t]
 131        ["Reset All" gnus-server-remove-denials t]))
 132
 133     (gnus-run-hooks 'gnus-server-menu-hook)))
 134
 135 (defvar gnus-server-mode-map nil)
 136 (put 'gnus-server-mode 'mode-class 'special)
 137
 138 (unless gnus-server-mode-map
 139   (setq gnus-server-mode-map (make-sparse-keymap))
 140   (suppress-keymap gnus-server-mode-map)
 141
 142   (gnus-define-keys gnus-server-mode-map
 143     " " gnus-server-read-server-in-server-buffer
 144     "\r" gnus-server-read-server
 145     gnus-mouse-2 gnus-server-pick-server
 146     "q" gnus-server-exit
 147     "l" gnus-server-list-servers
 148     "k" gnus-server-kill-server
 149     "y" gnus-server-yank-server
 150     "c" gnus-server-copy-server
 151     "a" gnus-server-add-server
 152     "e" gnus-server-edit-server
 153     "s" gnus-server-scan-server
 154
 155     "O" gnus-server-open-server
 156     "\M-o" gnus-server-open-all-servers
 157     "C" gnus-server-close-server
 158     "\M-c" gnus-server-close-all-servers
 159     "D" gnus-server-deny-server
 160     "L" gnus-server-offline-server
 161     "R" gnus-server-remove-denials
 162
 163     "n" next-line
 164     "p" previous-line
 165
 166     "g" gnus-server-regenerate-server
 167
 168     "z" gnus-server-compact-server
 169
 170     "\C-c\C-i" gnus-info-find-node
 171     "\C-c\C-b" gnus-bug))
 172
 173 (defface gnus-server-agent
 174   '((((class color) (background light)) (:foreground "PaleTurquoise" :bold t))
 175     (((class color) (background dark)) (:foreground "PaleTurquoise" :bold t))
 176     (t (:bold t)))
 177   "Face used for displaying AGENTIZED servers"
 178   :group 'gnus-server-visual)
 179 ;; backward-compatibility alias
 180 (put 'gnus-server-agent-face 'face-alias 'gnus-server-agent)
 181 (put 'gnus-server-agent-face 'obsolete-face "22.1")
 182
 183 (defface gnus-server-opened
 184   '((((class color) (background light)) (:foreground "Green3" :bold t))
 185     (((class color) (background dark)) (:foreground "Green1" :bold t))
 186     (t (:bold t)))
 187   "Face used for displaying OPENED servers"
 188   :group 'gnus-server-visual)
 189 ;; backward-compatibility alias
 190 (put 'gnus-server-opened-face 'face-alias 'gnus-server-opened)
 191 (put 'gnus-server-opened-face 'obsolete-face "22.1")
 192
 193 (defface gnus-server-closed
 194   '((((class color) (background light)) (:foreground "Steel Blue" :italic t))
 195     (((class color) (background dark))
 196      (:foreground "LightBlue" :italic t))
 197     (t (:italic t)))
 198   "Face used for displaying CLOSED servers"
 199   :group 'gnus-server-visual)
 200 ;; backward-compatibility alias
 201 (put 'gnus-server-closed-face 'face-alias 'gnus-server-closed)
 202 (put 'gnus-server-closed-face 'obsolete-face "22.1")
 203
 204 (defface gnus-server-denied
 205   '((((class color) (background light)) (:foreground "Red" :bold t))
 206     (((class color) (background dark)) (:foreground "Pink" :bold t))
 207     (t (:inverse-video t :bold t)))
 208   "Face used for displaying DENIED servers"
 209   :group 'gnus-server-visual)
 210 ;; backward-compatibility alias
 211 (put 'gnus-server-denied-face 'face-alias 'gnus-server-denied)
 212 (put 'gnus-server-denied-face 'obsolete-face "22.1")
 213
 214 (defface gnus-server-offline
 215   '((((class color) (background light)) (:foreground "Orange" :bold t))
 216     (((class color) (background dark)) (:foreground "Yellow" :bold t))
 217     (t (:inverse-video t :bold t)))
 218   "Face used for displaying OFFLINE servers"
 219   :group 'gnus-server-visual)
 220 ;; backward-compatibility alias
 221 (put 'gnus-server-offline-face 'face-alias 'gnus-server-offline)
 222 (put 'gnus-server-offline-face 'obsolete-face "22.1")
 223
 224 (defvar gnus-server-font-lock-keywords
 225   '(("(\\(agent\\))" 1 'gnus-server-agent)
 226     ("(\\(opened\\))" 1 'gnus-server-opened)
 227     ("(\\(closed\\))" 1 'gnus-server-closed)
 228     ("(\\(offline\\))" 1 'gnus-server-offline)
 229     ("(\\(denied\\))" 1 'gnus-server-denied)))
 230
 231 (defun gnus-server-mode ()
 232   "Major mode for listing and editing servers.
 233
 234 All normal editing commands are switched off.
 235 \\<gnus-server-mode-map>
 236 For more in-depth information on this mode, read the manual
 237 \(`\\[gnus-info-find-node]').
 238
 239 The following commands are available:
 240
 241 \\{gnus-server-mode-map}"
 242   (interactive)
 243   (when (gnus-visual-p 'server-menu 'menu)
 244     (gnus-server-make-menu-bar))
 245   (kill-all-local-variables)
 246   (gnus-simplify-mode-line)
 247   (setq major-mode 'gnus-server-mode)
 248   (setq mode-name "Server")
 249   (gnus-set-default-directory)
 250   (setq mode-line-process nil)
 251   (use-local-map gnus-server-mode-map)
 252   (buffer-disable-undo)
 253   (setq truncate-lines t)
 254   (setq buffer-read-only t)
 255   (if (featurep 'xemacs)
 256       (put 'gnus-server-mode 'font-lock-defaults '(gnus-server-font-lock-keywords t))
 257     (set (make-local-variable 'font-lock-defaults)
 258          '(gnus-server-font-lock-keywords t)))
 259   (gnus-run-mode-hooks 'gnus-server-mode-hook))
 260
 261 (defun gnus-server-insert-server-line (gnus-tmp-name method)
 262   (let* ((gnus-tmp-how (car method))
 263          (gnus-tmp-where (nth 1 method))
 264          (elem (assoc method gnus-opened-servers))
 265          (gnus-tmp-status
 266           (cond
 267            ((eq (nth 1 elem) 'denied) "(denied)")
 268            ((eq (nth 1 elem) 'offline) "(offline)")
 269            (t
 270             (condition-case nil
 271                 (if (or (gnus-server-opened method)
 272                         (eq (nth 1 elem) 'ok))
 273                     "(opened)"
 274                   "(closed)")
 275               ((error) "(error)")))))
 276          (gnus-tmp-agent (if (and gnus-agent
 277                                   (gnus-agent-method-p method))
 278                              " (agent)"
 279                            "")))
 280     (beginning-of-line)
 281     (gnus-add-text-properties
 282      (point)
 283      (prog1 (1+ (point))
 284        ;; Insert the text.
 285        (eval gnus-server-line-format-spec))
 286      (list 'gnus-server (intern gnus-tmp-name)
 287            'gnus-named-server (intern (gnus-method-to-server method t))))))
 288
 289 (defun gnus-enter-server-buffer ()
 290   "Set up the server buffer."
 291   (gnus-server-setup-buffer)
 292   (gnus-configure-windows 'server)
 293   ;; Usually `gnus-configure-windows' will finish with the
 294   ;; `gnus-server-buffer' selected as the current buffer, but not always (I
 295   ;; bumped into it when starting from a dedicated *Group* frame, and
 296   ;; gnus-configure-windows opened *Server* into its own dedicated frame).
 297   (with-current-buffer (get-buffer gnus-server-buffer)
 298     (gnus-server-prepare)))
 299
 300 (defun gnus-server-setup-buffer ()
 301   "Initialize the server buffer."
 302   (unless (get-buffer gnus-server-buffer)
 303     (with-current-buffer (gnus-get-buffer-create gnus-server-buffer)
 304       (gnus-server-mode))))
 305
 306 (defun gnus-server-prepare ()
 307   (gnus-set-format 'server-mode)
 308   (gnus-set-format 'server t)
 309   (let ((alist gnus-server-alist)
 310         (buffer-read-only nil)
 311         done server op-ser)
 312     (erase-buffer)
 313     (setq gnus-inserted-opened-servers nil)
 314     ;; First we do the real list of servers.
 315     (while alist
 316       (unless (member (cdar alist) done)
 317         (push (cdar alist) done)
 318         (setq server (pop alist))
 319         (when (and server (car server) (cdr server))
 320           (gnus-server-insert-server-line (car server) (cdr server))))
 321       (when (member (cdar alist) done)
 322         (pop alist)))
 323     ;; Then we insert the list of servers that have been opened in
 324     ;; this session.
 325     (dolist (open gnus-opened-servers)
 326       (when (and (not (member (car open) done))
 327                  ;; Just ignore ephemeral servers.
 328                  (not (member (car open) gnus-ephemeral-servers)))
 329         (push (car open) done)
 330         (gnus-server-insert-server-line
 331          (setq op-ser (format "%s:%s" (caar open) (nth 1 (car open))))
 332          (car open))
 333         (push (list op-ser (car open)) gnus-inserted-opened-servers))))
 334   (goto-char (point-min))
 335   (gnus-server-position-point))
 336
 337 (defun gnus-server-server-name ()
 338   (let ((server (get-text-property (point-at-bol) 'gnus-server)))
 339     (and server (symbol-name server))))
 340
 341 (defun gnus-server-named-server ()
 342   "Return a server name that matches one of the names returned by
 343 `gnus-method-to-server'."
 344   (let ((server (get-text-property (point-at-bol) 'gnus-named-server)))
 345     (and server (symbol-name server))))
 346
 347 (defalias 'gnus-server-position-point 'gnus-goto-colon)
 348
 349 (defconst gnus-server-edit-buffer "*Gnus edit server*")
 350
 351 (defun gnus-server-update-server (server)
 352   (with-current-buffer gnus-server-buffer
 353     (let* ((buffer-read-only nil)
 354            (entry (assoc server gnus-server-alist))
 355            (oentry (assoc (gnus-server-to-method server)
 356                           gnus-opened-servers)))
 357       (when entry
 358         (gnus-dribble-enter
 359          (concat "(gnus-server-set-info \"" server "\" '"
 360                  (gnus-prin1-to-string (cdr entry)) ")\n")))
 361       (when (or entry oentry)
 362         ;; Buffer may be narrowed.
 363         (save-restriction
 364           (widen)
 365           (when (gnus-server-goto-server server)
 366             (gnus-delete-line))
 367           (if entry
 368               (gnus-server-insert-server-line (car entry) (cdr entry))
 369             (gnus-server-insert-server-line
 370              (format "%s:%s" (caar oentry) (nth 1 (car oentry)))
 371              (car oentry)))
 372           (gnus-server-position-point))))))
 373
 374 (defun gnus-server-set-info (server info)
 375   ;; Enter a select method into the virtual server alist.
 376   (when (and server info)
 377     (gnus-dribble-enter
 378      (concat "(gnus-server-set-info \"" server "\" '"
 379              (gnus-prin1-to-string info) ")"))
 380     (let* ((server (nth 1 info))
 381            (entry (assoc server gnus-server-alist))
 382            (cached (assoc server gnus-server-method-cache)))
 383       (if cached
 384           (setq gnus-server-method-cache
 385                 (delq cached gnus-server-method-cache)))
 386       (if entry
 387           (progn
 388             ;; Remove the server from `gnus-opened-servers' since
 389             ;; it has never been opened with the new `info' yet.
 390             (gnus-opened-servers-remove (cdr entry))
 391             ;; Don't make a new Lisp object.
 392             (setcar (cdr entry) (car info))
 393             (setcdr (cdr entry) (cdr info)))
 394         (setq gnus-server-alist
 395               (nconc gnus-server-alist (list (cons server info))))))))
 396
 397 ;;; Interactive server functions.
 398
 399 (defun gnus-server-kill-server (server)