lisp/net/eudc-hotlist.el

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