cgit.sxemacs.org Git - packages/blob - xemacs-packages/eudc/eudc-hotlist.el

   1 ;;; eudc-hotlist.el --- hotlist management for EUDC
   2
   3 ;; Copyright (C) 1998 Free Software Foundation, Inc.
   4
   5 ;; Author: Oscar Figueiredo <oscar@xemacs.org>
   6 ;; Maintainer: Oscar Figueiredo <oscar@xemacs.org>
   7 ;; Created: Jun 1999
   8 ;; Version: $Revision: 1.4 $
   9 ;; Keywords: help
  10
  11 ;; This file is part of XEmacs
  12
  13 ;; XEmacs is free software; you can redistribute it and/or modify it
  14 ;; under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; XEmacs is distributed in the hope that it will be useful, but
  19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 ;; General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with XEmacs; see the file COPYING.  If not, write to
  25 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  26 ;; Boston, MA 02111-1307, USA.
  27
  28 ;;; Commentary:
  29
  30 ;;; Usage:
  31 ;;    See the corresponding info file
  32
  33 ;;; Code:
  34
  35 (require 'eudc)
  36
  37 (defvar eudc-hotlist-menu nil)
  38 (defvar eudc-hotlist-mode-map nil)
  39 (defvar eudc-hotlist-list-beginning nil)
  40
  41 (defun eudc-hotlist-mode ()
  42   "Major mode used to edit the hotlist of servers.
  43
  44 These are the special commands of this mode:
  45     a -- Add a new server to the list.
  46     d -- Delete the server at point from the list.
  47     s -- Select the server at point.
  48     t -- Transpose the server at point and the previous one
  49     q -- Commit the changes and quit.
  50     x -- Quit without commiting the changes."
  51   (interactive)
  52   (kill-all-local-variables)
  53   (setq major-mode 'eudc-hotlist-mode)
  54   (setq mode-name "EUDC-Servers")
  55   (use-local-map eudc-hotlist-mode-map)
  56   (setq mode-popup-menu eudc-hotlist-menu)
  57   (when (and eudc-xemacs-p
  58              (featurep 'menubar))
  59     (set-buffer-menubar current-menubar)
  60     (add-submenu nil (cons "EUDC-Hotlist" (cdr (cdr eudc-hotlist-menu)))))
  61   (setq buffer-read-only t))
  62
  63 ;;;###autoload
  64 (defun eudc-edit-hotlist ()
  65   "Edit the hotlist of directory servers in a specialized buffer."
  66   (interactive)
  67   (let ((proto-col 10)
  68         gap)
  69     (switch-to-buffer (get-buffer-create "*EUDC Servers*"))
  70     (setq buffer-read-only nil)
  71     (erase-buffer)
  72     (mapcar (function
  73              (lambda (entry)
  74                (setq proto-col (max (length (car entry)) proto-col))))
  75             eudc-server-hotlist)
  76     (setq proto-col (+ 3 proto-col))
  77     (setq gap (make-string (- proto-col 6) ?\ ))
  78     (insert "              EUDC Servers\n"
  79             "              ============\n"
  80             "\n"
  81             "Server" gap "Protocol\n"
  82             "------" gap "--------\n"
  83             "\n")
  84     (setq eudc-hotlist-list-beginning (point))
  85     (mapcar '(lambda (entry)
  86              (insert (car entry))
  87              (indent-to proto-col)
  88              (insert (symbol-name (cdr entry)) "\n"))
  89           eudc-server-hotlist)
  90   (eudc-hotlist-mode)))
  91
  92 (defun eudc-hotlist-add-server ()
  93   "Add a new server to the list after current one."
  94   (interactive)
  95   (if (not (eq major-mode 'eudc-hotlist-mode))
  96       (error "Not in a EUDC hotlist edit buffer"))
  97   (let ((server (read-from-minibuffer "Server: "))
  98         (protocol (completing-read "Protocol: "
  99                                    (mapcar '(lambda (elt)
 100                                               (cons (symbol-name elt)
 101                                                     elt))
 102                                            eudc-known-protocols)))
 103         (buffer-read-only nil))
 104     (if (not (eobp))
 105         (forward-line 1))
 106     (insert server)
 107     (indent-to 30)
 108     (insert protocol "\n")))
 109
 110 (defun eudc-hotlist-delete-server ()
 111   "Delete the server at point from the list."
 112   (interactive)
 113   (if (not (eq major-mode 'eudc-hotlist-mode))
 114       (error "Not in a EUDC hotlist edit buffer"))
 115   (let ((buffer-read-only nil))
 116     (save-excursion
 117       (beginning-of-line)
 118       (if (and (>= (point) eudc-hotlist-list-beginning)
 119                (looking-at "^\\([-.a-zA-Z:0-9]+\\)[ \t]+\\([a-zA-Z]+\\)"))
 120           (kill-line 1)
 121         (error "No server on this line")))))
 122
 123 (defun eudc-hotlist-quit-edit ()
 124   "Quit the hotlist editing mode and save changes to the hotlist."
 125   (interactive)
 126   (if (not (eq major-mode 'eudc-hotlist-mode))
 127       (error "Not in a EUDC hotlist edit buffer"))
 128   (let (hotlist)
 129     (goto-char eudc-hotlist-list-beginning)
 130     (while (looking-at "^\\([-.a-zA-Z:0-9]+\\)[ \t]+\\([a-zA-Z]+\\)")
 131       (setq hotlist (cons (cons (match-string 1)
 132                                 (intern (match-string 2)))
 133                           hotlist))
 134       (forward-line 1))
 135     (if (not (looking-at "^[ \t]*$"))
 136         (error "Malformed entry in hotlist, discarding edits"))
 137     (setq eudc-server-hotlist (nreverse hotlist))
 138     (eudc-install-menu)
 139     (eudc-save-options)
 140     (kill-this-buffer)))
 141
 142 (defun eudc-hotlist-select-server ()
 143   "Select the server at point as the current server."
 144   (interactive)
 145   (if (not (eq major-mode 'eudc-hotlist-mode))
 146       (error "Not in a EUDC hotlist edit buffer"))
 147   (save-excursion
 148     (beginning-of-line)
 149     (if (and (>= (point) eudc-hotlist-list-beginning)
 150              (looking-at "^\\([-.a-zA-Z:0-9]+\\)[ \t]+\\([a-zA-Z]+\\)"))
 151         (progn
 152           (eudc-set-server (match-string 1) (intern (match-string 2)))
 153           (message "Current directory server is %s (%s)" eudc-server eudc-protocol))
 154       (error "No server on this line"))))
 155
 156 (defun eudc-hotlist-transpose-servers ()
 157   "Swap the order of the server with the previous one in the list."
 158   (interactive)
 159   (if (not (eq major-mode 'eudc-hotlist-mode))
 160       (error "Not in a EUDC hotlist edit buffer"))
 161   (let ((buffer-read-only nil))
 162     (save-excursion
 163       (beginning-of-line)
 164       (if (and (>= (point) eudc-hotlist-list-beginning)
 165                (looking-at "^\\([-.a-zA-Z:0-9]+\\)[ \t]+\\([a-zA-Z]+\\)")
 166                (progn
 167                  (forward-line -1)
 168                  (looking-at "^\\([-.a-zA-Z:0-9]+\\)[ \t]+\\([a-zA-Z]+\\)")))
 169           (progn
 170             (forward-line 1)
 171             (transpose-lines 1))))))
 172
 173 (setq eudc-hotlist-mode-map
 174       (let ((map (make-sparse-keymap)))
 175         (define-key map "a" 'eudc-hotlist-add-server)
 176         (define-key map "d" 'eudc-hotlist-delete-server)
 177         (define-key map "s" 'eudc-hotlist-select-server)
 178         (define-key map "t" 'eudc-hotlist-transpose-servers)
 179         (define-key map "q" 'eudc-hotlist-quit-edit)
 180         (define-key map "x" 'kill-this-buffer)
 181         map))
 182
 183 (defconst eudc-hotlist-menu
 184   '("EUDC Hotlist Edit"
 185     ["---" nil nil]
 186     ["Add New Server" eudc-hotlist-add-server t]
 187     ["Delete Server" eudc-hotlist-delete-server t]
 188     ["Select Server" eudc-hotlist-select-server t]
 189     ["Transpose Servers" eudc-hotlist-transpose-servers t]
 190     ["Save and Quit" eudc-hotlist-quit-edit t]
 191     ["Exit without Saving" kill-this-buffer t]))
 192
 193 (if eudc-emacs-p
 194     (easy-menu-define eudc-hotlist-emacs-menu
 195                       eudc-hotlist-mode-map
 196                       ""
 197                       eudc-hotlist-menu))
 198
 199 ;;; eudc-hotlist.el ends here