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   (gnus-simplify-mode-line)
  99   (setq major-mode 'gnus-server-mode)
 100   (setq mode-name "Server")
 101                                         ;  (gnus-group-set-mode-line)
 102   (setq mode-line-process nil)
 103   (use-local-map gnus-server-mode-map)
 104   (buffer-disable-undo (current-buffer))
 105   (setq truncate-lines t)
 106   (setq buffer-read-only t)
 107   (run-hooks 'gnus-server-mode-hook))
 108
 109 (defun gnus-server-insert-server-line (name method)
 110   (let* ((how (car method))
 111          (where (nth 1 method))
 112          (elem (assoc method gnus-opened-servers))
 113          (status (cond ((eq (nth 1 elem) 'denied)
 114                         "(denied)")
 115                        ((or (gnus-server-opened method)
 116                             (eq (nth 1 elem) 'ok))
 117                         "(open)")
 118                        (t
 119                         "(closed)"))))
 120     (beginning-of-line)
 121     (add-text-properties
 122      (point)
 123      (prog1 (1+ (point))
 124        ;; Insert the text.
 125        (eval gnus-server-line-format-spec))
 126      (list 'gnus-server (intern name)))))
 127
 128 (defun gnus-enter-server-buffer ()
 129   "Set up the server buffer."
 130   (gnus-server-setup-buffer)
 131   (gnus-configure-windows 'server)
 132   (gnus-server-prepare))
 133
 134 (defun gnus-server-setup-buffer ()
 135   "Initialize the server buffer."
 136   (unless (get-buffer gnus-server-buffer)
 137     (save-excursion
 138       (set-buffer (get-buffer-create gnus-server-buffer))
 139       (gnus-server-mode)
 140       (when gnus-carpal
 141         (gnus-carpal-setup-buffer 'server)))))
 142
 143 (defun gnus-server-prepare ()
 144   (setq gnus-server-mode-line-format-spec
 145         (gnus-parse-format gnus-server-mode-line-format
 146                            gnus-server-mode-line-format-alist))
 147   (setq gnus-server-line-format-spec
 148         (gnus-parse-format gnus-server-line-format
 149                            gnus-server-line-format-alist t))
 150   (let ((alist gnus-server-alist)
 151         (buffer-read-only nil)
 152         (opened gnus-opened-servers)
 153         done server)
 154     (erase-buffer)
 155     ;; First we do the real list of servers.
 156     (while alist
 157       (push (cdr (setq server (pop alist))) done)
 158       (when server
 159         (gnus-server-insert-server-line (car server) (cdr server))))
 160     ;; Then we insert the list of servers that have been opened in
 161     ;; this session.
 162     (while opened
 163       (unless (member (car (car opened)) done)
 164         (gnus-server-insert-server-line
 165          (format "%s:%s" (car (car (car opened))) (nth 1 (car (car opened))))
 166          (car (car opened))))
 167       (setq opened (cdr opened))))
 168   (goto-char (point-min))
 169   (gnus-server-position-point))
 170
 171 (defun gnus-server-server-name ()
 172   (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server)))
 173     (and server (symbol-name server))))
 174
 175 (defalias 'gnus-server-position-point 'gnus-goto-colon)
 176
 177 (defconst gnus-server-edit-buffer "*Gnus edit server*")
 178
 179 (defun gnus-server-update-server (server)
 180   (save-excursion
 181     (set-buffer gnus-server-buffer)
 182     (let ((buffer-read-only nil)
 183           (info (cdr (assoc server gnus-server-alist))))
 184       (gnus-dribble-enter
 185        (concat "(gnus-server-set-info \"" server "\" '"
 186                (prin1-to-string info) ")"))
 187       ;; Buffer may be narrowed.
 188       (save-restriction
 189         (widen)
 190         (if (gnus-server-goto-server server)
 191             (delete-region (progn (beginning-of-line) (point))
 192                            (progn (forward-line 1) (point))))
 193         (let ((entry (assoc server gnus-server-alist)))
 194           (gnus-server-insert-server-line (car entry) (cdr entry))
 195           (gnus-server-position-point))))))
 196
 197 (defun gnus-server-set-info (server info)
 198   ;; Enter a select method into the virtual server alist.
 199   (gnus-dribble-enter
 200    (concat "(gnus-server-set-info \"" server "\" '"
 201            (prin1-to-string info) ")"))
 202   (let* ((server (nth 1 info))
 203          (entry (assoc server gnus-server-alist)))
 204     (if entry (setcdr entry info)
 205       (setq gnus-server-alist
 206             (nconc gnus-server-alist (list (cons server info)))))))
 207
 208 ;;; Interactive server functions.
 209
 210 (defun gnus-server-kill-server (server)
 211   "Kill the server on the current line."
 212   (interactive (list (gnus-server-server-name)))
 213   (or (gnus-server-goto-server server)
 214       (if server (error "No such server: %s" server)
 215         (error "No server on the current line")))
 216   (gnus-dribble-enter "")
 217   (let ((buffer-read-only nil))
 218     (delete-region (progn (beginning-of-line) (point))
 219                    (progn (forward-line 1) (point))))
 220   (setq gnus-server-killed-servers
 221         (cons (assoc server gnus-server-alist) gnus-server-killed-servers))
 222   (setq gnus-server-alist (delq (car gnus-server-killed-servers)
 223                                 gnus-server-alist))
 224   (gnus-server-position-point))
 225
 226 (defun gnus-server-yank-server ()
 227   "Yank the previously killed server."
 228   (interactive)
 229   (or gnus-server-killed-servers
 230       (error "No killed servers to be yanked"))
 231   (let ((alist gnus-server-alist)
 232         (server (gnus-server-server-name))
 233         (killed (car gnus-server-killed-servers)))
 234     (if (not server)
 235         (setq gnus-server-alist (nconc gnus-server-alist (list killed)))
 236       (if (string= server (car (car gnus-server-alist)))
 237           (setq gnus-server-alist (cons killed gnus-server-alist))
 238         (while (and (cdr alist)
 239                     (not (string= server (car (car (cdr alist))))))
 240           (setq alist (cdr alist)))
 241         (setcdr alist (cons killed (cdr alist)))
 242         (if alist
 243             (setcdr alist (cons killed (cdr alist)))
 244           (setq gnus-server-alist (list killed)))))
 245     (gnus-server-update-server (car killed))
 246     (setq gnus-server-killed-servers (cdr gnus-server-killed-servers))
 247     (gnus-server-position-point)))
 248
 249 (defun gnus-server-exit ()
 250   "Return to the group buffer."
 251   (interactive)
 252   (kill-buffer (current-buffer))
 253   (switch-to-buffer gnus-group-buffer))
 254
 255 (defun gnus-server-list-servers ()
 256   "List all available servers."
 257   (interactive)
 258   (let ((cur (gnus-server-server-name)))
 259     (gnus-server-prepare)
 260     (if cur (gnus-server-goto-server cur)
 261       (goto-char (point-max))
 262       (forward-line -1))
 263     (gnus-server-position-point)))
 264
 265 (defun gnus-opened-servers-remove (method)
 266   "Remove METHOD from the list of opened servers."
 267   (setq gnus-opened-servers (delq (assoc method gnus-opened-servers)
 268                                   gnus-opened-servers)))
 269
 270 (defun gnus-server-open-server (server)
 271   "Force an open of SERVER."
 272   (interactive (list (gnus-server-server-name)))
 273   (let ((method (gnus-server-to-method server)))
 274     (or method (error "No such server: %s" server))
 275     (gnus-opened-servers-remove method)
 276     (prog1
 277         (or (gnus-open-server method)
 278             (progn (message "Couldn't open %s" server) nil))
 279       (gnus-server-update-server server)
 280       (gnus-server-position-point))))
 281
 282 (defun gnus-server-close-server (server)
 283   "Close SERVER."
 284   (interactive (list (gnus-server-server-name)))
 285   (let ((method (gnus-server-to-method server)))
 286     (or method (error "No such server: %s" server))
 287     (gnus-opened-servers-remove method)
 288     (prog1
 289         (gnus-close-server method)
 290       (gnus-server-update-server server)
 291       (gnus-server-position-point))))
 292
 293 (defun gnus-server-deny-server (server)
 294   "Make sure SERVER will never be attempted opened."
 295   (interactive (list (gnus-server-server-name)))
 296   (let ((method (gnus-server-to-method server)))
 297     (or method (error "No such server: %s" server))
 298     (gnus-opened-servers-remove method)
 299     (setq gnus-opened-servers
 300           (cons (list method 'denied) gnus-opened-servers)))
 301   (gnus-server-update-server server)
 302   (gnus-server-position-point))
 303
 304 (defun gnus-server-remove-denials ()
 305   "Make all denied servers into closed servers."
 306   (interactive)
 307   (let ((servers gnus-opened-servers))
 308     (while servers
 309       (when (eq (nth 1 (car servers)) 'denied)
 310         (setcar (nthcdr 1 (car servers)) 'closed))
 311       (setq servers (cdr servers))))
 312   (gnus-server-list-servers))
 313
 314 (defun gnus-server-copy-server (from to)
 315   (interactive
 316    (list
 317     (or (gnus-server-server-name)
 318         (error "No server on the current line"))
 319     (read-string "Copy to: ")))
 320   (or from (error "No server on current line"))
 321   (or (and to (not (string= to ""))) (error "No name to copy to"))
 322   (and (assoc to gnus-server-alist) (error "%s already exists" to))
 323   (or (assoc from gnus-server-alist)
 324       (error "%s: no such server" from))
 325   (let ((to-entry (gnus-copy-sequence (assoc from gnus-server-alist))))
 326     (setcar to-entry to)
 327     (setcar (nthcdr 2 to-entry) to)
 328     (setq gnus-server-killed-servers
 329           (cons to-entry gnus-server-killed-servers))
 330     (gnus-server-yank-server)))
 331
 332 (defun gnus-server-add-server (how where)
 333   (interactive
 334    (list (intern (completing-read "Server method: "
 335                                   gnus-valid-select-methods nil t))
 336          (read-string "Server name: ")))
 337   (setq gnus-server-killed-servers
 338         (cons (list where how where) gnus-server-killed-servers))
 339   (gnus-server-yank-server))
 340
 341 (defun gnus-server-goto-server (server)
 342   "Jump to a server line."
 343   (interactive
 344    (list (completing-read "Goto server: " gnus-server-alist nil t)))
 345   (let ((to (text-property-any (point-min) (point-max)
 346                                'gnus-server (intern server))))
 347     (and to
 348          (progn
 349            (goto-char to)
 350            (gnus-server-position-point)))))
 351
 352 (defun gnus-server-edit-server (server)
 353   "Edit the server on the current line."
 354   (interactive (list (gnus-server-server-name)))
 355   (or server
 356       (error "No server on current line"))
 357   (let ((winconf (current-window-configuration)))
 358     (get-buffer-create gnus-server-edit-buffer)
 359     (gnus-configure-windows 'edit-server)
 360     (gnus-add-current-to-buffer-list)
 361     (emacs-lisp-mode)
 362     (make-local-variable 'gnus-prev-winconf)
 363     (setq gnus-prev-winconf winconf)
 364     (use-local-map (copy-keymap (current-local-map)))
 365     (let ((done-func '(lambda ()
 366                         "Exit editing mode and update the information."
 367                         (interactive)
 368                         (gnus-server-edit-server-done 'group))))
 369       (setcar (cdr (nth 4 done-func)) server)
 370       (local-set-key "\C-c\C-c" done-func))
 371     (erase-buffer)
 372     (insert ";; Type `C-c C-c' after you have edited the server.\n\n")
 373     (insert (pp-to-string (cdr (assoc server gnus-server-alist))))))
 374
 375 (defun gnus-server-edit-server-done (server)
 376   (interactive)
 377   (set-buffer (get-buffer-create gnus-server-edit-buffer))
 378   (goto-char (point-min))
 379   (let ((form (read (current-buffer)))
 380         (winconf gnus-prev-winconf))
 381     (gnus-server-set-info server form)
 382     (kill-buffer (current-buffer))
 383     (and winconf (set-window-configuration winconf))
 384     (set-buffer gnus-server-buffer)
 385     (gnus-server-update-server (gnus-server-server-name))
 386     (gnus-server-list-servers)
 387     (gnus-server-position-point)))
 388
 389 (defun gnus-server-read-server (server)
 390   "Browse a server."
 391   (interactive (list (gnus-server-server-name)))
 392   (let ((buf (current-buffer)))
 393     (prog1
 394         (gnus-browse-foreign-server (gnus-server-to-method server) buf)
 395       (save-excursion
 396         (set-buffer buf)
 397         (gnus-server-update-server (gnus-server-server-name))
 398         (gnus-server-position-point)))))
 399
 400 (defun gnus-server-pick-server (e)
 401   (interactive "e")
 402   (mouse-set-point e)
 403   (gnus-server-read-server (gnus-server-server-name)))
 404
 405 ;;; gnus-srvr.el ends here.