lisp/net/eudc-hotlist.el

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