cgit.sxemacs.org Git - packages/blob - xemacs-packages/oo-browser/br-name.el

   1 ;;!emacs
   2 ;;
   3 ;; FILE:         br-name.el
   4 ;; SUMMARY:      Maintain a user-specific set of names associated with OO-Browser Environments.
   5 ;; USAGE:        GNU Emacs Lisp Library
   6 ;; KEYWORDS:     oop, tools
   7 ;;
   8 ;; AUTHOR:       Bob Weiner
   9 ;; ORG:          BeOpen.com
  10 ;;
  11 ;; ORIG-DATE:    22-Aug-98 at 00:46:02
  12 ;; LAST-MOD:     15-Aug-99 at 05:18:03 by Bob Weiner
  13 ;;
  14 ;; Copyright (C) 1998  BeOpen.com
  15 ;; See the file BR-COPY for license information.
  16 ;;
  17 ;; This file is part of the OO-Browser.
  18 ;;
  19 ;; DESCRIPTION:
  20 ;; DESCRIP-END.
  21
  22 ;;; ************************************************************************
  23 ;;; Other required Elisp libraries
  24 ;;; ************************************************************************
  25
  26 (require 'hasht)
  27 (require 'hversion)
  28
  29 ;;; ************************************************************************
  30 ;;; Public variables
  31 ;;; ************************************************************************
  32
  33 (defvar br-env-name nil
  34   "Unique user-specific name for the current OO-Browser Environment.
  35 Valid values are:
  36   nil      - not yet initialized for the current Environment;
  37   t        - there is no user-specific name for this Environment; use its
  38              filename in operations instead
  39   <string> - Env name")
  40
  41 (defvar br-names-file
  42     (if hyperb:microcruft-os-p
  43         "c:/_oo-browser"
  44       (expand-file-name ".oo-browser" (concat "~" (user-real-login-name))))
  45   "File which stores OO-Browser unique Environment name to pathname associations.
  46 Its value is ~/.oo-browser or c:/_oo-browser (under MS OSes).")
  47
  48 (defvar br-names-htable (hash-make 1)
  49   "Hash table of OO-Browser-Env-Name keys and Env-File values.
  50 Its entries are user-specific; they are read from the ~/.oo-browser or
  51 ~/_oo-browser file (under MS OSes).")
  52
  53 ;;; ************************************************************************
  54 ;;; Private variables
  55 ;;; ************************************************************************
  56
  57 (defvar br-names-alist t
  58   "Temporary alist of (OO-Browser-Env-File . Env-Name) read from `br-names-file'.
  59 Value of `t' means it has not yet been initialized from the file.")
  60
  61 (defvar br-names-menu-cache t
  62   "Cache of menu items which load Environments by name.
  63 Value of `t' means it needs to be reinitialized.")
  64
  65 ;;; ************************************************************************
  66 ;;; Public functions
  67 ;;; ************************************************************************
  68
  69 (if (fboundp 'abbreviate-file-name)
  70     (if (string-match "XEmacs" emacs-version)
  71         (defun br-abbreviate-file-name (filename)
  72           "Shorten FILENAME as much as possible based on `directory-abbrev-alist' and home directory."
  73           (abbreviate-file-name filename t))
  74       (defalias 'br-abbreviate-file-name 'abbreviate-file-name))
  75   (defun br-abbreviate-file-name (filename)
  76     "Return filename unchanged since no abbreviation function is available."
  77     filename))
  78
  79 (defun br-name-add (env-name env-file)
  80   "Add a unique ENV-NAME string associated with ENV-FILE.
  81 Return the unique ENV-NAME.  If ENV-NAME is nil, it is interactively read."
  82   (interactive
  83    (list (setq env-name (br-name-read "Unique name for Environment: " nil))
  84          (br-env-read-file-name
  85           (format "Associate `%s' with file: " env-name))))
  86   (if (and (null env-name) (stringp env-file))
  87       (setq env-name (br-name-read
  88                       (format "Give name to \"%s\": "
  89                               (br-abbreviate-file-name env-file))
  90                       nil)))
  91   (if (eq env-name t)
  92       t
  93     (br-name-validate-arg-string "env-name" env-name)
  94     (br-name-validate-arg-string "env-file" env-file)
  95     (setq env-file (expand-file-name env-file))
  96     (if (br-name-get-env-file env-name)
  97         (error "(OO-Browser): Env `%s' exists, try renaming or removing it."
  98                env-name)
  99       (hash-add env-file env-name br-names-htable)
 100       (br-names-save)
 101       env-name)))
 102
 103 (defun br-name-change (env-name new-env-name)
 104   "Change ENV-NAME to NEW-ENV-NAME."
 105   (interactive
 106    (progn (setq env-name (br-name-read "Change Environment name: " t
 107                                        br-env-name))
 108           (list env-name
 109                 (br-name-read
 110                  (format "Change Environment name `%s' to: " env-name)
 111                  nil))))
 112   (br-name-validate-arg-string "env-name" env-name)
 113   (br-name-validate-arg-string "new-env-name" new-env-name)
 114   (let ((env-file (br-name-get-env-file env-name)))
 115     (if env-file
 116         (progn
 117           (hash-delete env-name br-names-htable)
 118           (hash-add env-file new-env-name br-names-htable)
 119           (br-names-save)
 120           (if (interactive-p)
 121               (message "Environment name `%s' changed to `%s'"
 122                        env-name new-env-name)))
 123       (error "(OO-Browser): br-name-change - `%s' does not exist"
 124              env-name))))
 125
 126 (defun br-name-get-env-file (env-name)
 127   "Return Env file associated with ENV-NAME."
 128   (if (stringp env-name)
 129       (hash-get env-name br-names-htable)))
 130
 131 (defun br-name-get (env-file)
 132   "Return the first Env name associated with ENV-FILE or nil."
 133   (br-name-validate-arg-string "env-file" env-file)
 134   (setq env-file (expand-file-name env-file))
 135   (catch 'env-name
 136     (hash-map
 137      (function (lambda (pathname-name-cons)
 138                  (if (string-equal env-file (car pathname-name-cons))
 139                      (throw 'env-name (cdr pathname-name-cons)))))
 140      br-names-htable)
 141     nil))
 142
 143 (defun br-name-read (&optional prompt must-match initial-name)
 144   "Interactively PROMPT for and return an existing (if MUST-MATCH is non-nil) OO-Browser Environment name, starting with INITIAL-NAME.
 145 All arguments are optional.  Return nil if no such names exist."
 146   (if (or (and must-match (hash-empty-p br-names-htable))
 147           noninteractive)
 148       t
 149     (let ((env-name)
 150           (completion-ignore-case t))
 151       (while (null env-name)
 152         (setq env-name
 153               (completing-read (or prompt "Environment name: ")
 154                                (hash-obarray br-names-htable)
 155                                nil must-match initial-name)
 156               ;; Clear out initial-name so it does not reappear each time
 157               ;; the user is re-prompted for a name.
 158               initial-name nil)
 159         (cond ((and (stringp env-name) (string-equal env-name ""))
 160                ;; Return t to signal no Env name selection.
 161                (setq env-name t))
 162               ((and (stringp env-name) (string-match "\\`\\s-*\\'" env-name))
 163                (beep) (setq env-name nil))))
 164       env-name)))
 165
 166 (defun br-name-remove (env-name)
 167   "Remove ENV-NAME's association with an Env file.
 168 This does not delete the associated Env file.
 169 Return non-nil iff ENV-NAME is associated with an Env file."
 170   (interactive (list (br-name-read "Remove Environment named: " t
 171                                    br-env-name)))
 172   (br-name-validate-arg-string "env-name" env-name)
 173   (prog1 (hash-delete env-name br-names-htable)
 174     (br-names-save)
 175     (if (interactive-p)
 176         (message "Environment name `%s' removed" env-name))))
 177
 178 (defun br-name-replace (env-name new-env-file)
 179   "Replace ENV-NAME's associated Env file with NEW-ENV-FILE."
 180   (br-name-validate-arg-string "env-name" env-name)
 181   (br-name-validate-arg-string "new-env-file" new-env-file)
 182   (setq new-env-file (expand-file-name new-env-file))
 183   (hash-add new-env-file env-name br-names-htable)
 184   (br-names-save)
 185   (if (interactive-p)
 186       (message "`%s' associated with \"%s\"" env-name new-env-file)))
 187
 188 (defun br-names-display ()
 189   "Display the user-specific list of OO-Browser Environment names and files."
 190   (interactive)
 191   (if (fboundp 'with-displaying-help-buffer)
 192       (with-displaying-help-buffer 'br-names-display-internal
 193                                    "*OO-Browser Environments*")
 194     (with-output-to-temp-buffer "*OO-Browser Environments*"
 195       (br-names-display-internal))))
 196
 197 (defun br-names-empty-p ()
 198   "Return t if there no Environment names have been added or loaded, else nil."
 199   (or (not (hashp br-names-htable)) (hash-empty-p br-names-htable)))
 200
 201 (defun br-names-initialize ()
 202   "Initialize Env name to file associations if not already done."
 203   (if (eq br-names-alist t)
 204       (br-names-read-file nil)))
 205
 206 (defun br-names-list ()
 207   "Return the user-specific list of OO-Browser (Environment-File . Environment-name) pairs."
 208   (hash-map 'identity br-names-htable))
 209
 210 ;;;###autoload
 211 (defun br-names-menu (menu-items)
 212   "Return an unnamed menu of commands that load a user's named OO-Browser Environments."
 213   (if (eq br-names-menu-cache t)
 214       (progn
 215         (br-names-initialize)
 216         (if (hash-empty-p br-names-htable)
 217             (setq br-names-menu-cache nil)
 218           (setq br-names-menu-cache
 219                 (append
 220                  (sort
 221                   (hash-map
 222                    (if (featurep 'infodock)
 223                        (function
 224                         (lambda (pathname-name-cons)
 225                           (vector (cdr pathname-name-cons)
 226                                   `(let ((id-tool-visible-flag 'visible))
 227                                      (id-tool '(br-env-browse
 228                                                 ,(car pathname-name-cons)
 229                                                 ,(cdr pathname-name-cons))
 230                                               'OO-Browser 'br-mode 1))
 231                                   t)))
 232                      (function (lambda (pathname-name-cons)
 233                                  (vector (cdr pathname-name-cons)
 234                                          `(br-env-browse
 235                                            ,(car pathname-name-cons)
 236                                            ,(cdr pathname-name-cons))
 237                                          t))))
 238                    br-names-htable)
 239                   (function (lambda (menu-item1 menu-item2)
 240                               (string-lessp (elt menu-item1 0)
 241                                             (elt menu-item2 0)))))
 242                  menu-items))))
 243     br-names-menu-cache))
 244
 245 (defun br-names-read-file (&optional env-names-file)
 246   "Read from optional ENV-NAMES-FILE or `br-names-file' Env name and file associations.
 247 If the file to be read does not exist, nothing is done and nil is returned.
 248 If the file is unreadable or not of the right format, an error is signaled.
 249 If the file is read properly, `br-names-htable' is initialized and t is
 250 returned."
 251   (interactive (list
 252                 (read-file-name "Read Environment names file: "
 253                                 nil
 254                                 br-names-file t)))
 255   (or env-names-file (setq env-names-file br-names-file))
 256   (br-name-validate-arg-string "env-names-file" env-names-file)
 257   (if (not (file-exists-p env-names-file))
 258       ;; Do nothing when file does not exist.
 259       nil
 260     (if (not (file-readable-p env-names-file))
 261         (error "(OO-Browser): \"%s\" does not exist or is unreadable"
 262                env-names-file))
 263     ;; Should set `br-names-alist'.
 264     (condition-case ()
 265         (progn (load-file env-names-file)
 266                (if (eq br-names-alist t)
 267                    (signal-error 'error nil)
 268                  (mapcar
 269                   (function (lambda (pathname-name-cons)
 270                               (hash-add (car pathname-name-cons)
 271                                         (cdr pathname-name-cons)
 272                                         br-names-htable)))
 273                   br-names-alist)
 274                  t))
 275       (error (error "(OO-Browser): \"%s\" is an invalid Environment names file"
 276                     env-names-file)))))
 277
 278 ;;; ************************************************************************
 279 ;;; Private functions
 280 ;;; ************************************************************************
 281
 282 (defun br-names-display-internal ()
 283   (if (featurep 'hyperbole)
 284       (princ "Press the Action Key within a pathname to load that Environment:\n\n"))
 285   (mapcar
 286    'princ
 287    (sort (hash-map
 288           (function
 289            (lambda (pathname-name-cons)
 290              (format (format "%%-%ds - \"%%s\"\n"
 291                              (apply 'max
 292                                     (hash-map
 293                                      (function
 294                                       (lambda (pathname-name-cons)
 295                                         (length (cdr pathname-name-cons))))
 296                                      br-names-htable)))
 297                      (cdr pathname-name-cons)
 298                      (br-abbreviate-file-name (car pathname-name-cons)))))
 299           br-names-htable) 'string-lessp)))
 300
 301 (defun br-name-validate-arg-string (arg-name arg-val)
 302  (cond ((or (eq arg-val t) (equal arg-val ""))
 303         (error "(OO-Browser): Aborting command, no value given for `%s'"
 304         arg-name))
 305        ((not (stringp arg-val))
 306         (error "(OO-Browser): Invalid `%s' value, `%s'"
 307                arg-name arg-val))
 308        (t)))
 309
 310 (defun br-names-save ()
 311   "Save the user-specific list of existing OO-Browser Environment names."
 312   ;; Force reinitialization of names menu.
 313   (setq br-names-menu-cache t)
 314   (save-excursion
 315     (let ((standard-output (set-buffer (find-file-noselect br-names-file))))
 316       (setq buffer-read-only nil)
 317       (erase-buffer)
 318       (princ "(setq br-names-alist\n'")
 319       (if (hash-empty-p br-names-htable)
 320           (princ nil)
 321         (hash-prin1 br-names-htable))
 322       (princ ")\n")
 323       (save-buffer))))
 324
 325 (provide 'br-name)