4 ;; SUMMARY: Maintain a user-specific set of names associated with OO-Browser Environments.
5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: oop, tools
11 ;; ORIG-DATE: 22-Aug-98 at 00:46:02
12 ;; LAST-MOD: 15-Aug-99 at 05:18:03 by Bob Weiner
14 ;; Copyright (C) 1998 BeOpen.com
15 ;; See the file BR-COPY for license information.
17 ;; This file is part of the OO-Browser.
22 ;;; ************************************************************************
23 ;;; Other required Elisp libraries
24 ;;; ************************************************************************
29 ;;; ************************************************************************
31 ;;; ************************************************************************
33 (defvar br-env-name nil
34 "Unique user-specific name for the current OO-Browser Environment.
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
42 (if hyperb:microcruft-os-p
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).")
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).")
53 ;;; ************************************************************************
55 ;;; ************************************************************************
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.")
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.")
65 ;;; ************************************************************************
67 ;;; ************************************************************************
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."
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."
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))
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."
99 (hash-add env-file env-name br-names-htable)
103 (defun br-name-change (env-name new-env-name)
104 "Change ENV-NAME to NEW-ENV-NAME."
106 (progn (setq env-name (br-name-read "Change Environment name: " t
110 (format "Change Environment name `%s' to: " env-name)
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)))
117 (hash-delete env-name br-names-htable)
118 (hash-add env-file new-env-name br-names-htable)
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"
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)))
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))
137 (function (lambda (pathname-name-cons)
138 (if (string-equal env-file (car pathname-name-cons))
139 (throw 'env-name (cdr pathname-name-cons)))))
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))
150 (completion-ignore-case t))
151 (while (null 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.
159 (cond ((and (stringp env-name) (string-equal env-name ""))
160 ;; Return t to signal no Env name selection.
162 ((and (stringp env-name) (string-match "\\`\\s-*\\'" env-name))
163 (beep) (setq env-name nil))))
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
172 (br-name-validate-arg-string "env-name" env-name)
173 (prog1 (hash-delete env-name br-names-htable)
176 (message "Environment name `%s' removed" env-name))))
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)
186 (message "`%s' associated with \"%s\"" env-name new-env-file)))
188 (defun br-names-display ()
189 "Display the user-specific list of OO-Browser Environment names and files."
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))))
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)))
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)))
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))
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)
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
222 (if (featurep 'infodock)
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))
232 (function (lambda (pathname-name-cons)
233 (vector (cdr pathname-name-cons)
235 ,(car pathname-name-cons)
236 ,(cdr pathname-name-cons))
239 (function (lambda (menu-item1 menu-item2)
240 (string-lessp (elt menu-item1 0)
241 (elt menu-item2 0)))))
243 br-names-menu-cache))
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
252 (read-file-name "Read Environment names file: "
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.
260 (if (not (file-readable-p env-names-file))
261 (error "(OO-Browser): \"%s\" does not exist or is unreadable"
263 ;; Should set `br-names-alist'.
265 (progn (load-file env-names-file)
266 (if (eq br-names-alist t)
267 (signal-error 'error nil)
269 (function (lambda (pathname-name-cons)
270 (hash-add (car pathname-name-cons)
271 (cdr pathname-name-cons)
275 (error (error "(OO-Browser): \"%s\" is an invalid Environment names file"
278 ;;; ************************************************************************
279 ;;; Private functions
280 ;;; ************************************************************************
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"))
289 (lambda (pathname-name-cons)
290 (format (format "%%-%ds - \"%%s\"\n"
294 (lambda (pathname-name-cons)
295 (length (cdr pathname-name-cons))))
297 (cdr pathname-name-cons)
298 (br-abbreviate-file-name (car pathname-name-cons)))))
299 br-names-htable) 'string-lessp)))
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'"
305 ((not (stringp arg-val))
306 (error "(OO-Browser): Invalid `%s' value, `%s'"
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)
315 (let ((standard-output (set-buffer (find-file-noselect br-names-file))))
316 (setq buffer-read-only nil)
318 (princ "(setq br-names-alist\n'")
319 (if (hash-empty-p br-names-htable)
321 (hash-prin1 br-names-htable))