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

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