|
0
|
1 ;;!emacs
|
|
|
2 ;;
|
|
|
3 ;; FILE: br-env.el
|
|
|
4 ;; SUMMARY: OO-Browser Environment support functions.
|
|
|
5 ;; USAGE: GNU Emacs Lisp Library
|
|
|
6 ;; KEYWORDS: oop, tools
|
|
|
7 ;;
|
|
|
8 ;; AUTHOR: Bob Weiner
|
|
100
|
9 ;; ORG: InfoDock Associates
|
|
0
|
10 ;;
|
|
|
11 ;; ORIG-DATE: 8-Jun-90
|
|
100
|
12 ;; LAST-MOD: 21-Feb-97 at 17:22:39 by Bob Weiner
|
|
0
|
13 ;;
|
|
100
|
14 ;; Copyright (C) 1989-1995, 1997 Free Software Foundation, Inc.
|
|
0
|
15 ;; See the file BR-COPY for license information.
|
|
|
16 ;;
|
|
|
17 ;; This file is part of the OO-Browser.
|
|
|
18
|
|
|
19 ;;; ************************************************************************
|
|
|
20 ;;; Other required Elisp libraries
|
|
|
21 ;;; ************************************************************************
|
|
|
22
|
|
|
23 (require 'hasht)
|
|
|
24
|
|
|
25 ;;; ************************************************************************
|
|
|
26 ;;; Public variables
|
|
|
27 ;;; ************************************************************************
|
|
|
28
|
|
|
29 (defvar br-env-default-file "OOBR"
|
|
|
30 "*Standard file name for OO-Browser Environment storage.")
|
|
|
31
|
|
|
32 (defvar br-env-file nil
|
|
|
33 "Default file into which to save a class Environment.
|
|
|
34 Value is language-specific.")
|
|
|
35
|
|
|
36 ;;; ************************************************************************
|
|
|
37 ;;; Public functions
|
|
|
38 ;;; ************************************************************************
|
|
|
39
|
|
|
40 (if (fboundp 'file-relative-name)
|
|
|
41 nil
|
|
|
42 ;; For V18 Emacs
|
|
|
43 (defun file-relative-name (filename &optional directory)
|
|
|
44 "Convert FILENAME to be relative to DIRECTORY (default: default-directory)."
|
|
|
45 (setq filename (expand-file-name filename)
|
|
|
46 directory (file-name-as-directory (if directory
|
|
|
47 (expand-file-name directory)
|
|
|
48 default-directory)))
|
|
|
49 (while directory
|
|
|
50 (let ((up (file-name-directory (directory-file-name directory))))
|
|
|
51 (cond ((and (string-equal directory up)
|
|
|
52 (file-name-absolute-p directory))
|
|
|
53 ;; "/"
|
|
|
54 (setq directory nil))
|
|
|
55 ((string-match (concat "\\`" (regexp-quote directory))
|
|
|
56 filename)
|
|
|
57 (setq filename (substring filename (match-end 0)))
|
|
|
58 (setq directory nil))
|
|
|
59 (t
|
|
|
60 ;; go up one level
|
|
|
61 (setq directory up)))))
|
|
|
62 filename))
|
|
|
63
|
|
|
64 ;;;###autoload
|
|
|
65 (defun br-env-browse (env-file)
|
|
|
66 "Invoke the OO-Browser on an existing or to be created Environment ENV-FILE."
|
|
|
67 (interactive
|
|
|
68 (list (read-file-name "Load/Create OO-Browser Environment: "
|
|
|
69 nil (or br-env-file br-env-default-file))))
|
|
|
70 (if (stringp env-file)
|
|
|
71 (setq env-file (expand-file-name env-file))
|
|
|
72 (error "(br-env-browse): Invalid env file: '%s'" env-file))
|
|
|
73 (if (string-match "-FTR$" env-file)
|
|
|
74 (setq env-file (substring env-file 0 (match-beginning 0))))
|
|
|
75 (cond ((and (file-exists-p env-file)
|
|
|
76 (not (file-readable-p env-file)))
|
|
|
77 (error "(br-env-browse): Env file '%s' is unreadable." env-file))
|
|
|
78 ((not (file-exists-p env-file))
|
|
|
79 ;; Specify a new Environment
|
|
|
80 (funcall (intern-soft (concat (br-env-select-lang) "browse"))
|
|
|
81 env-file))
|
|
|
82 (t ;; Existing Environment
|
|
|
83 (let ((lang-string))
|
|
|
84 (save-excursion
|
|
|
85 (set-buffer (find-file-noselect env-file))
|
|
|
86 (save-restriction
|
|
|
87 (widen)
|
|
|
88 (goto-char (point-min))
|
|
|
89 (if (search-forward "br-lang-prefix" nil t)
|
|
|
90 (progn (forward-line 1)
|
|
|
91 ;; Eval removes quote from in front of lang-string
|
|
|
92 ;; value which is read from the Env file.
|
|
|
93 (setq lang-string (eval (read (current-buffer))))))))
|
|
|
94 (if lang-string
|
|
|
95 (funcall (intern-soft (concat lang-string "browse"))
|
|
|
96 env-file)
|
|
|
97 (error "(br-env-browse): Invalid env file: '%s'" env-file))))))
|
|
|
98
|
|
|
99 (defun br-env-build (&optional env-file background-flag)
|
|
|
100 "Build Environment from spec given by optional ENV-FILE or 'br-env-file'.
|
|
|
101 If optional 2nd argument BACKGROUND-FLAG is t, build the Environment
|
|
|
102 using a background process. If it is nil, build in foreground. Any other
|
|
|
103 value prompts for whether to build in the background."
|
|
|
104 (interactive
|
|
|
105 (let ((env-file (br-env-default-file)))
|
|
|
106 (list (read-file-name
|
|
|
107 (format "Build Environment (default \"%s\"): "
|
|
|
108 (br-relative-path env-file))
|
|
|
109 (file-name-directory env-file)
|
|
|
110 env-file t)
|
|
|
111 'prompt)))
|
|
|
112 (cond ((or (null background-flag) (eq background-flag t)))
|
|
|
113 (noninteractive
|
|
|
114 (setq background-flag nil))
|
|
|
115 (t (setq background-flag
|
|
|
116 (y-or-n-p "Build Environment in a background process? "))))
|
|
|
117 (if (or (not (stringp env-file)) (equal env-file ""))
|
|
|
118 (setq env-file br-env-file))
|
|
|
119 (setq env-file (expand-file-name env-file))
|
|
|
120 (or (not (file-exists-p env-file)) (file-readable-p env-file)
|
|
|
121 (error (format "Non-readable Environment file, %s" env-file)))
|
|
|
122 (or (file-writable-p env-file)
|
|
|
123 (error (format "Non-writable Environment file, %s" env-file)))
|
|
|
124 (if background-flag
|
|
|
125 (progn (setenv "OOBR_DIR" br-directory)
|
|
|
126 (setenv "OOBR_ENV" env-file)
|
|
|
127 (compile (format
|
|
|
128 "make -f %s %s oobr-env"
|
|
|
129 (expand-file-name "Makefile" br-directory)
|
|
|
130 (if (and (boundp 'invocation-directory)
|
|
|
131 (boundp 'invocation-name)
|
|
|
132 (stringp invocation-directory)
|
|
|
133 (stringp invocation-name)
|
|
|
134 (file-directory-p invocation-directory)
|
|
|
135 (file-name-absolute-p invocation-directory))
|
|
|
136 (concat "EMACS="
|
|
|
137 (expand-file-name
|
|
|
138 invocation-name invocation-directory))
|
|
|
139 ""))))
|
|
|
140 (br-env-load env-file nil t)
|
|
|
141 ;; Detach unneeded data so can be garbage collected.
|
|
|
142 (br-env-create-alists)
|
|
|
143 (br-env-create-htables)
|
|
|
144 (if (and (boundp 'br-feature-tags-file) (stringp br-feature-tags-file))
|
|
|
145 (progn
|
|
|
146 (if (not (file-writable-p br-feature-tags-file))
|
|
|
147 (error
|
|
|
148 "(br-env-build): %s is not writable" br-feature-tags-file))
|
|
|
149 (set-buffer (find-file-noselect br-feature-tags-file))
|
|
|
150 (setq buffer-read-only nil)
|
|
|
151 (erase-buffer)
|
|
|
152 (set-buffer-modified-p nil)))
|
|
|
153 (br-build-sys-htable)
|
|
|
154 (br-build-lib-htable)
|
|
|
155 (setq br-env-spec nil)
|
|
|
156 (br-env-save)
|
|
|
157 ;; Detach unneeded data so can be garbage collected.
|
|
|
158 (br-env-create-alists)
|
|
|
159 (br-env-load env-file nil t)))
|
|
|
160
|
|
|
161 (defun br-env-rebuild ()
|
|
|
162 "Rescan System and Library sources associated with the current Environment."
|
|
|
163 (interactive)
|
|
|
164 (cond ((interactive-p)
|
|
|
165 (if (y-or-n-p "Rebuild current Environment? ")
|
|
|
166 (br-env-build nil 'prompt)))
|
|
|
167 (t (error "(br-env-rebuild): This must be called interactively."))))
|
|
|
168
|
|
|
169 (defun br-env-create (&optional env-file lang-prefix)
|
|
|
170 "Create and save the specification of a new OO-Browser Environment.
|
|
|
171 Interactively prompt for the Environment file name or use optional ENV-FILE.
|
|
|
172 Interactively prompt for the Environment language to use or use optional
|
|
|
173 LANG-PREFIX as language indicator.
|
|
|
174
|
|
|
175 If called non-interactively, do not build the Environment.
|
|
|
176 If called interactively and presently in the OO-Browser and the current
|
|
|
177 Environment is the one that has been re-specified, automatically rebuild it.
|
|
|
178 Otherwise, prompt for whether to build the Environment.
|
|
|
179
|
|
|
180 Return the name of the Environment specification file that was created."
|
|
|
181 (interactive)
|
|
|
182 (if env-file
|
|
|
183 (read-string
|
|
100
|
184 (format "Please specify the \"%s\" Environment (Hit RET to begin)."
|
|
0
|
185 (file-name-nondirectory env-file)))
|
|
|
186 (setq env-file (br-env-default-file)
|
|
|
187 env-file (read-file-name
|
|
|
188 (format "Create Env spec file (default \"%s\"): "
|
|
|
189 (br-relative-path env-file))
|
|
|
190 (file-name-directory env-file)
|
|
|
191 env-file nil)))
|
|
|
192 (setq env-file (expand-file-name env-file))
|
|
|
193 ;; Display Env spec if previous one existed
|
|
|
194 (and (equal env-file br-env-file) (file-readable-p env-file) (br-env-stats))
|
|
100
|
195 (let ((prompt "System search dir #%d (RET to end): ")
|
|
0
|
196 (br-env-spec t)
|
|
|
197 br-sys-search-dirs br-lib-search-dirs
|
|
|
198 br-lang-prefix
|
|
|
199 br-children-htable
|
|
|
200 br-sys-paths-htable
|
|
|
201 br-sys-parents-htable
|
|
|
202 br-lib-paths-htable
|
|
|
203 br-lib-parents-htable
|
|
|
204 br-paths-htable
|
|
|
205 br-parents-htable)
|
|
|
206 (br-env-create-htables)
|
|
|
207 (setq br-lang-prefix (or lang-prefix (br-env-select-lang))
|
|
|
208 br-sys-search-dirs (br-env-get-dirs prompt)
|
|
100
|
209 prompt "Library search dir #%d (RET to end): "
|
|
0
|
210 br-lib-search-dirs (br-env-get-dirs prompt))
|
|
|
211 ;; Now since user has not aborted, set real variables
|
|
|
212 (setq br-env-spec t)
|
|
|
213 (br-env-save env-file)
|
|
|
214 ;; If called interactively and re-specifying current Env, then also
|
|
|
215 ;; rebuild it.
|
|
|
216 (if (interactive-p)
|
|
|
217 (if (equal env-file br-env-file)
|
|
|
218 (if (br-in-browser)
|
|
|
219 ;; auto-build
|
|
|
220 (br-env-build
|
|
|
221 nil (y-or-n-p "Environment will now be built. Build in background? "))
|
|
|
222 (call-interactively 'br-env-build))))
|
|
|
223 env-file))
|
|
|
224
|
|
|
225 ;;;###autoload
|
|
|
226 (defun br-env-load (&optional env-file prompt no-build)
|
|
|
227 "Load browser Environment or spec from optional ENV-FILE or 'br-env-file'.
|
|
|
228 Non-nil PROMPT means prompt user before building tables.
|
|
|
229 Non-nil NO-BUILD means skip build of Environment entirely.
|
|
|
230 Return t if load is successful, else nil."
|
|
|
231 (interactive
|
|
|
232 (let ((env-file (br-env-default-file)))
|
|
|
233 (list (read-file-name
|
|
|
234 (format "Environment file to load (default \"%s\"): "
|
|
|
235 (br-relative-path env-file))
|
|
|
236 (file-name-directory env-file)
|
|
|
237 env-file t))))
|
|
|
238 (setq env-file (or (and (not (equal env-file "")) env-file)
|
|
|
239 (br-env-default-file))
|
|
|
240 env-file (expand-file-name env-file)
|
|
|
241 br-env-file env-file)
|
|
|
242 (let ((buf (get-file-buffer env-file)))
|
|
|
243 (and buf (kill-buffer buf)))
|
|
|
244 (let ((br-loaded))
|
|
|
245 (if (file-readable-p env-file)
|
|
|
246 (unwind-protect
|
|
|
247 (progn
|
|
|
248 (message "Loading Environment...")
|
|
|
249 (sit-for 1)
|
|
|
250 ;; Ensure spec and version values are nil for old
|
|
|
251 ;; Environment files that do not contain a setting for
|
|
|
252 ;; these variables.
|
|
|
253 (setq br-env-spec nil br-env-version nil)
|
|
|
254 (load-file env-file)
|
|
|
255
|
|
|
256 (if br-env-spec
|
|
|
257 nil
|
|
|
258 (setq br-children-htable (hash-make br-children-alist)
|
|
|
259 br-sys-paths-htable (hash-make br-sys-paths-alist)
|
|
|
260 br-lib-paths-htable (hash-make br-lib-paths-alist)
|
|
|
261 br-sys-parents-htable
|
|
|
262 (hash-make br-sys-parents-alist)
|
|
|
263 br-lib-parents-htable
|
|
|
264 (hash-make br-lib-parents-alist)
|
|
|
265 )
|
|
|
266 (br-env-set-htables))
|
|
|
267
|
|
|
268 ;; Prevent rebuilding of Environment
|
|
|
269 (setq br-lib-prev-search-dirs br-lib-search-dirs
|
|
|
270 br-sys-prev-search-dirs br-sys-search-dirs)
|
|
|
271 (setq br-loaded t)
|
|
|
272 (message "Loading Environment...Done")
|
|
|
273 (cond
|
|
|
274 ((and br-env-spec (not no-build))
|
|
|
275 (setq br-loaded
|
|
|
276 (br-env-cond-build
|
|
|
277 env-file
|
|
|
278 (if prompt "Build Environment from spec in file, \"%s\"? "))))
|
|
|
279 ;; If Environment was built with a version of the OO-Browser
|
|
|
280 ;; which did not add a version number to each Environment,
|
|
|
281 ;; then it may use an obsolete format. Offer to rebuild it.
|
|
|
282 ((and (not no-build) (null br-env-version)
|
|
|
283 (br-member br-lang-prefix '("c++-" "objc-" "eif-")))
|
|
|
284 (br-env-stats)
|
|
|
285 (br-env-cond-build
|
|
|
286 env-file
|
|
|
287 (if prompt
|
|
|
288 "Environment file format is obsolete, rebuild it? ")))))
|
|
100
|
289 ;; Ensure that OO-Browser support libraries for the current
|
|
|
290 ;; language are loaded, since this function may be called without
|
|
|
291 ;; invoking the OO-Browser user interface.
|
|
|
292 (let ((lang-symbol (intern-soft (concat br-lang-prefix "browse")))
|
|
|
293 lang-setup-symbol
|
|
|
294 lang-function)
|
|
|
295 (if lang-symbol
|
|
|
296 (progn (setq lang-function (symbol-function lang-symbol))
|
|
|
297 (and (listp lang-function) (eq (car lang-function) 'autoload)
|
|
|
298 (load (car (cdr lang-function)))
|
|
|
299 ;; Initialize language-specific browser variables.
|
|
|
300 (setq lang-setup-symbol (intern-soft (concat br-lang-prefix "browse-setup")))
|
|
|
301 (funcall lang-setup-symbol)))))
|
|
0
|
302 nil)
|
|
|
303 (if (file-exists-p env-file)
|
|
|
304 (progn (beep)
|
|
|
305 (message "No read rights for Envir file, \"%s\"" env-file)
|
|
|
306 (sit-for 4))
|
|
|
307 (message "\"%s\", no such file." env-file)
|
|
|
308 (sit-for 2)
|
|
|
309 (setq br-loaded (br-env-load
|
|
|
310 (br-env-create env-file br-lang-prefix) t))))
|
|
|
311 br-loaded))
|
|
|
312
|
|
|
313 (defun br-env-save (&optional save-file)
|
|
|
314 "Save changed Environment to file given by optional SAVE-FILE or 'br-env-file'."
|
|
|
315 (interactive
|
|
|
316 (let ((env-file (br-env-default-file)))
|
|
|
317 (list (read-file-name
|
|
|
318 (format "Save Environment to (default \"%s\"): "
|
|
|
319 (br-relative-path env-file))
|
|
|
320 (file-name-directory env-file)
|
|
|
321 env-file nil))))
|
|
|
322 (if (and (stringp save-file)
|
|
|
323 (not (equal save-file br-env-file))
|
|
|
324 (stringp br-feature-tags-file)
|
|
|
325 (file-exists-p br-feature-tags-file))
|
|
|
326 ;; Copy feature tags file to new file name.
|
|
|
327 (copy-file br-feature-tags-file (br-feature-tags-file-name save-file)
|
|
|
328 t t))
|
|
|
329 (if (or (not (stringp save-file)) (equal save-file ""))
|
|
|
330 (setq save-file br-env-file))
|
|
|
331 (setq save-file (expand-file-name save-file))
|
|
|
332 (or (file-writable-p save-file)
|
|
|
333 (error (format "Non-writable Environment file, \"%s\""
|
|
|
334 save-file)))
|
|
|
335 (let ((buf (get-file-buffer save-file)))
|
|
|
336 (and buf (kill-buffer buf)))
|
|
|
337 (let ((dir (or (file-name-directory save-file)
|
|
|
338 default-directory)))
|
|
|
339 (or (file-writable-p dir)
|
|
|
340 (error (format "Non-writable Environment directory, \"%s\"" dir))))
|
|
|
341 (save-window-excursion
|
|
|
342 (let ((standard-output
|
|
|
343 (set-buffer (funcall br-find-file-noselect-function
|
|
|
344 save-file)))
|
|
|
345 (buffer-read-only)
|
|
|
346 br-sym)
|
|
|
347 (erase-buffer)
|
|
|
348 (princ "\n(setq\nbr-env-version")
|
|
|
349 (print br-version)
|
|
|
350 (br-env-save-mult-vars (cons (car br-env-mult-vars) nil))
|
|
|
351 (mapcar (function
|
|
|
352 (lambda (nm)
|
|
|
353 (setq br-sym (intern-soft (concat "br-" nm)))
|
|
|
354 (let ((nm-mid (string-match "-htable$" nm)))
|
|
|
355 (if nm-mid
|
|
|
356 (progn (princ "\nbr-") (princ (substring nm 0 nm-mid))
|
|
|
357 (princ "-alist\n'")
|
|
|
358 (hash-prin1 (symbol-value br-sym)))
|
|
|
359 (princ "\n") (princ br-sym) (princ "\n'")
|
|
|
360 (prin1 (symbol-value br-sym)) (princ "\n")))))
|
|
|
361 br-env-single-vars)
|
|
|
362 (br-env-save-mult-vars (cdr br-env-mult-vars))
|
|
|
363 (princ ")\n")
|
|
|
364 (save-buffer)
|
|
|
365 (kill-buffer standard-output))))
|
|
|
366
|
|
|
367 (defun br-env-stats (&optional arg)
|
|
|
368 "Display summary for current Environment in viewer window.
|
|
|
369 With optional prefix ARG, display class totals in minibuffer."
|
|
|
370 (interactive "P")
|
|
|
371 (let ((env-file (abbreviate-file-name br-env-file)))
|
|
|
372 (if arg
|
|
|
373 (message "Envir \"%s\": %s" env-file (br-env-totals))
|
|
|
374 (br-funcall-in-view-window
|
|
100
|
375 (concat br-buffer-prefix-info "Info*")
|
|
0
|
376 (function
|
|
|
377 (lambda ()
|
|
|
378 (insert (format "Environment: \"%s\"" env-file))
|
|
|
379 (center-line)
|
|
|
380 (insert "\n\n")
|
|
|
381 (if (null br-env-spec)
|
|
|
382 (insert (format "Built by version %s of the OO-Browser.\n\n"
|
|
|
383 (or br-env-version "earlier than 02.09.03"))))
|
|
|
384 (insert (br-env-totals) "\n\n")
|
|
|
385 (let ((undefined (br-undefined-classes)))
|
|
|
386 (if undefined
|
|
|
387 (insert (format "Undefined classes: %s\n\n" undefined))))
|
|
|
388 (mapcar
|
|
|
389 (function
|
|
|
390 (lambda (sys-lib)
|
|
|
391 (insert (format "Directories to search for %s classes:\n"
|
|
|
392 (car sys-lib)))
|
|
|
393 (if (cdr sys-lib)
|
|
|
394 (progn (mapcar
|
|
|
395 (function
|
|
|
396 (lambda (dir)
|
|
|
397 (or (equal dir "")
|
|
|
398 (insert
|
|
|
399 (format "\t%s\n"
|
|
|
400 (abbreviate-file-name dir))))))
|
|
|
401 (cdr sys-lib))
|
|
|
402 (insert "\n"))
|
|
|
403 (insert "\t<None>\n\n"))))
|
|
|
404 (list (cons "System" br-sys-search-dirs)
|
|
|
405 (cons "Library" br-lib-search-dirs)))
|
|
|
406 (insert "Flag Settings:"
|
|
|
407 "\n\tEnvironment built from specification: "
|
|
|
408 (if br-env-spec "no" "yes")
|
|
|
409 "\n")
|
|
|
410 (set-buffer-modified-p nil)))))))
|
|
|
411
|
|
|
412 ;;; ************************************************************************
|
|
|
413 ;;; Private functions
|
|
|
414 ;;; ************************************************************************
|
|
|
415
|
|
|
416 (defun br-env-add-ref-classes (&optional htable-type)
|
|
|
417 "Add classes to Environment which are referenced in it but not defined.
|
|
|
418 With optional HTABLE-TYPE, affect only that part of the Environment.
|
|
|
419 HTABLE-TYPE may be \"sys\"or \"lib\". By default, add to both Library and
|
|
|
420 whole Environment tables."
|
|
|
421 ;;
|
|
|
422 ;; This function must NOT call any 'get-htable' type functions or it will
|
|
|
423 ;; cause an infinite loop.
|
|
|
424 (let ((classes (br-all-classes
|
|
|
425 (symbol-value
|
|
|
426 (intern-soft (concat "br-" htable-type
|
|
|
427 (if htable-type "-")
|
|
|
428 "paths-htable")))))
|
|
|
429 (pars (br-env-all-parents
|
|
|
430 (symbol-value
|
|
|
431 (intern-soft (concat "br-" htable-type
|
|
|
432 (if htable-type "-")
|
|
|
433 "parents-htable")))))
|
|
|
434 (class))
|
|
|
435 (while pars
|
|
|
436 (setq class (car pars)
|
|
|
437 pars (cdr pars))
|
|
|
438 (if (or (null class) (br-member class classes))
|
|
|
439 nil
|
|
|
440 (setq classes (cons class classes))
|
|
|
441 (if (null htable-type) (setq htable-type "lib"))
|
|
|
442 (br-env-add-to-htables class (concat htable-type "-parents"))
|
|
|
443 (br-add-to-paths-htable
|
|
|
444 class br-null-path
|
|
|
445 (br-get-htable (concat htable-type "-paths")))))))
|
|
|
446
|
|
|
447 (defun br-env-add-to-htables (class parents)
|
|
|
448 "Add CLASS to hash tables referenced by PARENTS name.
|
|
|
449 PARENTS may be \"parents\", \"sys-parents\", or \"lib-parents\"."
|
|
|
450 (if (null class)
|
|
|
451 nil
|
|
|
452 (setq parents
|
|
|
453 (symbol-value (intern-soft (concat "br-" parents "-htable"))))
|
|
|
454 (if parents (hash-add nil class parents))))
|
|
|
455
|
|
|
456 (defun br-env-all-parents (&optional htable-type)
|
|
|
457 "Return list of all parent names in Environment or optional HTABLE-TYPE.
|
|
|
458 HTABLE-TYPE may be \"sys\" or \"lib\". or an actual hash table."
|
|
|
459 (apply 'append
|
|
|
460 (hash-map 'car
|
|
|
461 (cond ((and (stringp htable-type)
|
|
|
462 (not (string-equal htable-type "")))
|
|
|
463 (br-get-htable (concat htable-type "-parents")))
|
|
|
464 ((hashp htable-type) htable-type)
|
|
|
465 (t (br-get-parents-htable))))))
|
|
|
466
|
|
|
467 (defun br-env-batch-build ()
|
|
|
468 "Build Environments from specifications while running Emacs in batch mode.
|
|
|
469 Invoke via a shell command line of the following form:
|
|
|
470 emacs -batch -l <BR-DIR>/br-start.el <OO-Browser Env Spec File> ... <Spec File> -f br-env-batch-build"
|
|
|
471 (br-init-autoloads)
|
|
|
472 (if (or (not (boundp 'br-directory)) (null br-directory)
|
|
|
473 (not (file-exists-p br-directory)))
|
|
|
474 (error "br-env-batch-build: Set 'br-directory' properly before use.")
|
|
|
475 (let ((spec-file)
|
|
|
476 (files (delq nil (mapcar 'buffer-file-name (buffer-list)))))
|
|
|
477 (while (setq spec-file (car files))
|
|
|
478 (setq files (cdr files))
|
|
|
479 (load spec-file)
|
|
|
480 (or (featurep (intern-soft (concat br-lang-prefix "browse")))
|
|
|
481 (featurep (intern-soft (concat br-lang-prefix "brows")))
|
|
|
482 (load (expand-file-name
|
|
|
483 (concat br-lang-prefix "browse") br-directory)
|
|
|
484 t)
|
|
|
485 (load (expand-file-name
|
|
|
486 (concat br-lang-prefix "brows") br-directory)))
|
|
|
487 (funcall (intern (concat br-lang-prefix "browse-setup")))
|
|
|
488 (kill-buffer nil)
|
|
|
489 (br-env-build spec-file nil)))))
|
|
|
490
|
|
|
491 ;;; The following function is called by the compilation sentinel whenever a
|
|
|
492 ;;; compilation finishes under versions of Emacs 19. (If you use Emacs 18,
|
|
|
493 ;;; you would have to edit compilation-sentinel to call the function stored
|
|
|
494 ;;; in 'compilation-finish-function' as Emacs 19, compile.el does.
|
|
|
495 ;;;
|
|
|
496 ;;; If there already is a compilation-finish-function, save it and use it
|
|
|
497 ;;; when not in a batch environment build.
|
|
|
498 (setq compilation-original-finish-function
|
|
|
499 (and (boundp 'compilation-finish-function)
|
|
|
500 (not (eq compilation-finish-function 'br-env-batch-build-browse))
|
|
|
501 compilation-finish-function)
|
|
|
502 compilation-finish-function 'br-env-batch-build-browse)
|
|
|
503
|
|
|
504 (defun br-env-batch-build-browse (&rest args)
|
|
|
505 ;; This is only called when we are in the compilation buffer already.
|
|
|
506 (cond ((not (string-match "oobr-env" compile-command))
|
|
|
507 ;; Some other type of build.
|
|
|
508 (if compilation-original-finish-function
|
|
|
509 (apply compilation-original-finish-function args)))
|
|
|
510 ((not (and (stringp mode-line-process)
|
|
|
511 (string-match "OK" mode-line-process)))
|
|
|
512 ;; Build failed.
|
|
|
513 nil)
|
|
|
514 (t ;; Environment build was successful.
|
|
|
515 (beep)
|
|
|
516 (let* ((env-file (getenv "OOBR_ENV"))
|
|
|
517 (prompt
|
|
|
518 (format
|
|
|
519 "(OO-Browser): Environment \"%s\" is built; browse it now? "
|
|
|
520 (file-name-nondirectory env-file))))
|
|
|
521 (if (y-or-n-p prompt)
|
|
|
522 (br-env-browse env-file))))))
|
|
|
523
|
|
|
524 (defun br-env-cond-build (env-file prompt)
|
|
|
525 "Build current Environment from its specification and save it in ENV-FILE.
|
|
|
526 Non-nil PROMPT is used to prompt user before building Environment. Return t
|
|
|
527 iff current Environment gets built from specification."
|
|
|
528 (let ((dir (or (file-name-directory env-file)
|
|
|
529 default-directory)))
|
|
|
530 (if (not (file-writable-p dir))
|
|
|
531 (progn (beep)
|
|
|
532 (message "Unwritable Environment directory, \"%s\"" dir)
|
|
|
533 (sit-for 4) nil)
|
|
|
534 (if (or (not prompt)
|
|
|
535 (y-or-n-p (format prompt env-file)))
|
|
|
536 (progn (br-env-build env-file 'prompt) t)))))
|
|
|
537
|
|
|
538 (defun br-env-copy (to-br)
|
|
|
539 "Copy 'br-' Environment to or from 'br-lang-prefix' language variables.
|
|
|
540 If TO-BR is non-nil, copy from language-specific variables to browser
|
|
|
541 variables. Otherwise, do copy in the reverse direction."
|
|
|
542 (let* ((var1) (var2)
|
|
|
543 (copy-func
|
|
|
544 (if to-br (function (lambda () (set var1 (symbol-value var2))))
|
|
|
545 (function (lambda () (set var2 (symbol-value var1)))))))
|
|
|
546 (mapcar (function
|
|
|
547 (lambda (nm)
|
|
|
548 (setq var1 (intern (concat "br-" nm))
|
|
|
549 var2 (intern (concat br-lang-prefix nm)))
|
|
|
550 (funcall copy-func)))
|
|
|
551 (append
|
|
|
552 '("env-file" "env-version" "lib-search-dirs"
|
|
|
553 "lib-prev-search-dirs" "lib-parents-htable"
|
|
|
554 "lib-paths-htable" "sys-search-dirs"
|
|
|
555 "sys-prev-search-dirs" "sys-parents-htable"
|
|
|
556 "sys-paths-htable" "paths-htable" "parents-htable")
|
|
|
557 br-env-single-vars))))
|
|
|
558
|
|
|
559 (defun br-env-create-alists ()
|
|
|
560 "Create all empty Environment association lists."
|
|
|
561 (setq br-children-alist nil
|
|
|
562 br-sys-paths-alist nil br-lib-paths-alist nil
|
|
|
563 br-sys-parents-alist nil br-lib-parents-alist nil
|
|
|
564 br-paths-alist nil br-parents-alist nil))
|
|
|
565
|
|
|
566 (defun br-env-create-htables ()
|
|
|
567 "Create all empty Environment hash tables."
|
|
|
568 (setq br-children-htable (hash-make 0)
|
|
|
569 br-sys-paths-htable (hash-make 0)
|
|
|
570 br-sys-parents-htable (hash-make 0)
|
|
|
571 br-lib-paths-htable (hash-make 0)
|
|
|
572 br-lib-parents-htable (hash-make 0)
|
|
|
573 br-paths-htable (hash-make 0)
|
|
|
574 br-parents-htable (hash-make 0)))
|
|
|
575
|
|
|
576 (defun br-env-default-file (&optional directory)
|
|
|
577 "Search up current or optional DIRECTORY tree for an OO-Browser environment file.
|
|
|
578 Return file name found, the value of 'br-env-file' if non-nil, or else the
|
|
|
579 value of 'br-env-default-file'. All return values are expanded to absolute
|
|
|
580 paths before being returned."
|
|
|
581 (let ((path directory)
|
|
100
|
582 (oo-browser-file))
|
|
0
|
583 (while (and (stringp path)
|
|
|
584 (setq path (file-name-directory path))
|
|
|
585 (setq path (directory-file-name path))
|
|
|
586 ;; Not at root directory
|
|
|
587 (not (string-match ":?/\\'" path))
|
|
|
588 ;; No environment file
|
|
|
589 (not (file-exists-p
|
|
100
|
590 (setq oo-browser-file (expand-file-name
|
|
0
|
591 br-env-default-file path)))))
|
|
100
|
592 (setq oo-browser-file nil))
|
|
|
593 (expand-file-name (or oo-browser-file br-env-file br-env-default-file))))
|
|
0
|
594
|
|
|
595 (defun br-env-file-sym-val (symbol-name)
|
|
|
596 "Given a SYMBOL-NAME, a string, find its value in the current Environment file.
|
|
|
597 Assume the Environment file to use is attached to the current buffer.
|
|
|
598 Only search for the SYMBOL-NAME from the current point in the buffer.
|
|
|
599 Return cons whose car is t iff SYMBOL-NAME was found and then whose cdr is the
|
|
|
600 non-quoted value found."
|
|
|
601 (set-buffer (funcall br-find-file-noselect-function br-env-file))
|
|
|
602 (save-excursion
|
|
|
603 (if (search-forward symbol-name nil t)
|
|
|
604 (let ((standard-input (current-buffer)))
|
|
|
605 (cons t (eval (read)))))))
|
|
|
606
|
|
|
607 (defun br-env-try-load (env-file default-file)
|
|
|
608 "Try to load a complete Environment, initially given by ENV-FILE.
|
|
|
609 If an Environment specification is selected, the user will be prompted
|
|
|
610 whether or not to build it. If ENV-FILE is not a string, the function will
|
|
|
611 prompt for an Environment to load. DEFAULT-FILE is the default file to use
|
|
|
612 when an empty value is given at the Environment file prompt.
|
|
|
613
|
|
|
614 Return the name of the Environment file that was loaded or nil."
|
|
|
615 (if (br-env-load
|
|
|
616 (if (stringp env-file)
|
|
|
617 env-file
|
|
|
618 (or (stringp default-file)
|
|
|
619 (setq default-file (br-env-default-file)))
|
|
|
620 (setq env-file
|
|
|
621 (read-file-name
|
|
|
622 (format
|
|
|
623 "OO-Browser Environment file (default \"%s\"): "
|
|
|
624 (br-relative-path default-file))
|
|
|
625 nil
|
|
|
626 default-file nil)))
|
|
|
627 'prompt)
|
|
|
628 (if (stringp env-file)
|
|
|
629 (setq br-env-file (expand-file-name env-file)))))
|
|
|
630
|
|
|
631 (defun br-env-get-dirs (prompt)
|
|
|
632 "PROMPT for and return list of directory names.
|
|
|
633 PROMPT must contain a %d somewhere in it, so dir # may be inserted."
|
|
|
634 (let ((dir) (dirs) (num 1) (default ""))
|
|
|
635 (while (not (string-equal "" (setq dir (read-file-name
|
|
|
636 (format prompt num) default "" t))))
|
|
|
637 (if (file-directory-p dir)
|
|
|
638 (setq dirs (cons dir dirs)
|
|
|
639 num (1+ num)
|
|
|
640 default "")
|
|
|
641 (beep)
|
|
|
642 (setq default dir)))
|
|
|
643 (nreverse dirs)))
|
|
|
644
|
|
|
645 (defun br-env-init (env-file same-lang same-env)
|
|
|
646 "Load or build ENV-FILE if non-nil.
|
|
|
647 Otherwise, use 'br-env-file' if non-nil or if not, interactively prompt for
|
|
|
648 Environment name. SAME-LANG should be non-nil if invoking the OO-Browser on
|
|
|
649 the same language again. SAME-ENV should be non-nil if invoking the
|
|
|
650 OO-Browser on the same Environment again. br-sys/lib-search-dirs variables
|
|
|
651 should be set before this function is called.
|
|
|
652
|
|
|
653 Return the name of the current Environment file unless load attempt fails,
|
|
|
654 then return nil."
|
|
|
655 (cond
|
|
|
656
|
|
|
657 ;; Specific environment requested
|
|
|
658 (env-file
|
|
|
659 ;; Create or load spec and load or build Environment
|
|
|
660 (setq env-file (br-env-try-load env-file br-env-file)))
|
|
|
661
|
|
|
662 ;; First invocation on this lang
|
|
|
663 ((and (null br-sys-search-dirs) (null br-lib-search-dirs))
|
|
|
664 ;; Create or load spec and load or build Environment
|
|
|
665 (setq env-file
|
|
|
666 (br-env-try-load (or br-env-file (br-env-create)) br-env-file)))
|
|
|
667
|
|
|
668 ;; Non-first invocation, search paths have been set, possibly default Env
|
|
|
669 (t
|
|
|
670 (setq env-file br-env-file)
|
|
|
671 (cond
|
|
|
672 ;; Continue browsing an Environment
|
|
|
673 (same-env nil)
|
|
|
674 (same-lang
|
|
|
675 ;; But search paths have changed, so rebuild Env
|
|
|
676 (progn (or (eq br-sys-search-dirs br-sys-prev-search-dirs)
|
|
|
677 (br-build-sys-htable))
|
|
|
678 (or (eq br-lib-search-dirs br-lib-prev-search-dirs)
|
|
|
679 (br-build-lib-htable))))
|
|
|
680 ;; Request to browse a different language Env
|
|
|
681 (t
|
|
|
682 (setq env-file (br-env-try-load
|
|
|
683 (or br-env-file (br-env-create)) br-env-file))))))
|
|
|
684 ;; Return current Env file name unless load attempt failed, then return nil.
|
|
|
685 env-file)
|
|
|
686
|
|
|
687 (defun *br-env-internal-structures* ()
|
|
|
688 "Display values of internal data structures in viewer buffer."
|
|
|
689 (interactive)
|
|
|
690 (br-funcall-in-view-window
|
|
100
|
691 (concat br-buffer-prefix-info "Info*")
|
|
0
|
692 (function
|
|
|
693 (lambda ()
|
|
|
694 (let ((standard-output (current-buffer)))
|
|
|
695 (mapcar
|
|
|
696 (function
|
|
|
697 (lambda (sym)
|
|
|
698 (mapcar
|
|
|
699 (function (lambda (obj)
|
|
|
700 (princ obj)))
|
|
|
701 (list "!!! " (symbol-name sym) " !!!\n\n"
|
|
|
702 (symbol-value sym) "\n \n"))
|
|
|
703 ))
|
|
|
704 '(br-children-htable
|
|
|
705 br-parents-htable
|
|
|
706 br-paths-htable
|
|
|
707 br-sys-search-dirs
|
|
|
708 br-sys-paths-htable
|
|
|
709 br-sys-parents-htable
|
|
|
710 br-lib-search-dirs
|
|
|
711 br-lib-paths-htable
|
|
|
712 br-lib-parents-htable
|
|
|
713 br-lang-prefix
|
|
|
714 br-env-spec)))))))
|
|
|
715
|
|
|
716 (defun br-env-lang-dialog-box (dialog-box)
|
|
|
717 "Prompt user with DIALOG-BOX and return selected value.
|
|
|
718 Assumes caller has checked that 'dialog-box' function exists."
|
|
|
719 (let ((echo-keystrokes 0)
|
|
|
720 event-obj
|
|
|
721 event)
|
|
|
722 ;; Add a cancel button to dialog box.
|
|
|
723 (setq dialog-box (append dialog-box (list nil '["Cancel" abort t])))
|
|
|
724 (popup-dialog-box dialog-box)
|
|
|
725 (catch 'br-env-done
|
|
|
726 (while t
|
|
|
727 (setq event (next-command-event event)
|
|
|
728 event-obj (event-object event))
|
|
|
729 (cond ((and (menu-event-p event)
|
|
|
730 (memq event-obj '(abort menu-no-selection-hook)))
|
|
|
731 (signal 'quit nil))
|
|
|
732 ((button-release-event-p event) ;; don't beep twice
|
|
|
733 nil)
|
|
|
734 ((menu-event-p event)
|
|
|
735 (throw 'br-env-done (eval event-obj)))
|
|
|
736 (t
|
|
|
737 (beep)
|
|
|
738 (message "Please answer the dialog box.")))))))
|
|
|
739
|
|
|
740 (defun br-env-lang-var (lang-prefix)
|
|
|
741 "Create language-specific Environment variables for LANG-PREFIX."
|
|
|
742 (eval (list 'defvar (intern (concat lang-prefix "env-version"))
|
|
|
743 nil
|
|
|
744 "Version of the OO-Browser used to build the current Environment or nil."))
|
|
|
745 (eval (list 'defvar (intern (concat lang-prefix "env-file"))
|
|
|
746 br-env-default-file
|
|
|
747 "*File in which to save Environment.")))
|
|
|
748
|
|
|
749 (defun br-env-load-matching-htables (changed-types-list)
|
|
|
750 (let ((still-changed-types))
|
|
|
751 (if (file-readable-p br-env-file)
|
|
|
752 (unwind-protect
|
|
|
753 (progn
|
|
|
754 (let ((buf (get-file-buffer br-env-file)))
|
|
|
755 (and buf (kill-buffer buf)))
|
|
|
756 (set-buffer (funcall br-find-file-noselect-function br-env-file))
|
|
|
757 (goto-char (point-min))
|
|
|
758 (mapcar
|
|
|
759 (function
|
|
|
760 (lambda (type)
|
|
|
761 (let* ((search-dirs (concat "br-" type "-search-dirs"))
|
|
|
762 (prev-dirs (concat "br-" type "-prev-search-dirs"))
|
|
|
763 (paths (concat "br-" type "-paths-htable"))
|
|
|
764 (parents (concat "br-" type "-parents-htable"))
|
|
|
765 (dirs-val (cdr (br-env-file-sym-val search-dirs))))
|
|
|
766 (if (equal dirs-val (symbol-value (intern search-dirs)))
|
|
|
767 (and (br-member type changed-types-list)
|
|
|
768 (progn (set (intern paths)
|
|
|
769 (cdr (br-env-file-sym-val paths)))
|
|
|
770 (set (intern parents)
|
|
|
771 (cdr (br-env-file-sym-val parents)))
|
|
|
772 (set (intern prev-dirs)
|
|
|
773 (symbol-value
|
|
|
774 (intern search-dirs)))))
|
|
|
775 (setq still-changed-types
|
|
|
776 (cons type still-changed-types))))))
|
|
|
777 '("sys" "lib"))
|
|
|
778 )
|
|
|
779 nil))
|
|
|
780 (nreverse still-changed-types)))
|
|
|
781
|
|
|
782 (defun br-env-save-mult-vars (mult-vars)
|
|
|
783 (let ((br-sym))
|
|
|
784 (mapcar
|
|
|
785 (function
|
|
|
786 (lambda (suffix)
|
|
|
787 (mapcar
|
|
|
788 (function
|
|
|
789 (lambda (type-str)
|
|
|
790 (setq br-sym (intern-soft
|
|
|
791 (concat "br-" type-str suffix)))
|
|
|
792 (if (and br-sym (boundp br-sym))
|
|
|
793 (let* ((nm (symbol-name br-sym))
|
|
|
794 (nm-mid (string-match "-htable$" nm)))
|
|
|
795 (if nm-mid
|
|
|
796 (progn (princ "\n") (princ (substring nm 0 nm-mid))
|
|
|
797 (princ "-alist\n'")
|
|
|
798 (hash-prin1 (symbol-value br-sym)))
|
|
|
799 (princ "\n") (princ br-sym) (princ "\n'")
|
|
|
800 (prin1 (symbol-value br-sym))
|
|
|
801 (princ "\n"))))))
|
|
|
802 '("sys-" "lib-"))))
|
|
|
803 mult-vars)))
|
|
|
804
|
|
|
805 (defun br-env-set-htables ()
|
|
|
806 (br-env-add-ref-classes "lib")
|
|
|
807 (br-env-add-ref-classes "sys")
|
|
|
808 ;; Make System entries override Library entries which they duplicate, since
|
|
|
809 ;; this is generally more desireable than merging the two. Don't do this
|
|
|
810 ;; for the paths-htable, however, since the value is the union of both
|
|
|
811 ;; values.
|
|
|
812 (setq br-paths-htable (hash-merge br-sys-paths-htable br-lib-paths-htable))
|
|
|
813 (let ((hash-merge-values-function (function (lambda (val1 val2) val1))))
|
|
|
814 (setq br-parents-htable (hash-merge br-sys-parents-htable
|
|
|
815 br-lib-parents-htable))))
|
|
|
816
|
|
|
817 (defun br-env-select-lang ()
|
|
|
818 "Interactively select and return value for 'br-lang-prefix'."
|
|
|
819 (let ((n 0) (nlangs (length br-env-lang-avector))
|
|
|
820 (lang-prompt)
|
|
|
821 ;; Use dialog box if last user event involved the mouse.
|
|
|
822 (use-dialog-box (and (fboundp 'popup-dialog-box)
|
|
|
823 (fboundp 'button-press-event-p)
|
|
|
824 (or (button-press-event-p last-command-event)
|
|
|
825 (button-release-event-p last-command-event)
|
|
|
826 (menu-event-p last-command-event)))))
|
|
|
827 ;; Create a prompt numbering each OO-Browser language available.
|
|
|
828 (setq lang-prompt
|
|
|
829 (if use-dialog-box
|
|
|
830 (mapcar
|
|
|
831 (function (lambda (lang)
|
|
|
832 (setq n (1+ n))
|
|
|
833 (vector lang (list 'identity n) 't)))
|
|
|
834 (mapcar 'car br-env-lang-avector))
|
|
|
835 (mapconcat
|
|
|
836 (function (lambda (lang)
|
|
|
837 (setq n (1+ n))
|
|
|
838 (format "%d\) %s" n lang)))
|
|
|
839 (mapcar 'car br-env-lang-avector)
|
|
|
840 "; ")))
|
|
|
841 ;; Prompt user.
|
|
|
842 (while (progn
|
|
|
843 (setq n (if use-dialog-box
|
|
|
844 (br-env-lang-dialog-box
|
|
|
845 (cons "Choose language to browse: " lang-prompt))
|
|
|
846 ;; Otherwise, prompt in the minibuffer.
|
|
|
847 (string-to-int
|
|
|
848 (read-string (concat "Choose: " lang-prompt ": ") ""))))
|
|
|
849 (or (< n 1) (> n nlangs)))
|
|
|
850 (beep))
|
|
|
851 (cdr (aref br-env-lang-avector (1- n)))))
|
|
|
852
|
|
|
853 (defun br-env-totals ()
|
|
|
854 "Return string of Environment class totals."
|
|
|
855 (let ((sys (length (br-all-classes "sys")))
|
|
|
856 (lib (length (br-all-classes "lib")))
|
|
|
857 (duplicates (car (br-all-classes nil t)))
|
|
|
858 count)
|
|
|
859 (format "%sTotal unique classes: %d; System: %d; Library: %d"
|
|
|
860 (if (null duplicates)
|
|
|
861 ""
|
|
|
862 (setq count (length duplicates))
|
|
|
863 (format "%d DUPLICATE CLASS%s TO CONSIDER ELIMINATING:\n\t%s\n\n"
|
|
|
864 count (if (= count 1) "" "ES") duplicates))
|
|
|
865 (+ sys lib) sys lib)))
|
|
|
866
|
|
|
867 ;;; ************************************************************************
|
|
|
868 ;;; Internal variables
|
|
|
869 ;;; ************************************************************************
|
|
|
870
|
|
|
871 (defvar br-env-version nil
|
|
|
872 "Version of the OO-Browser used to build the current Environment or nil.")
|
|
|
873
|
|
|
874 (defconst br-env-mult-vars
|
|
|
875 '("search-dirs" "paths-htable" "parents-htable")
|
|
|
876 "Descriptors of multiple copy variables saved as part of an Environment.")
|
|
|
877 (defconst br-env-single-vars
|
|
|
878 '("lang-prefix" "env-spec" "children-htable")
|
|
|
879 "Descriptors of singular variables saved as part of an Environment.")
|
|
|
880
|
|
|
881 (defvar br-env-spec nil
|
|
|
882 "Non-nil value means Environment specification has been given but not yet built.
|
|
|
883 Nil means current Environment has been built, though it may still require
|
|
|
884 updating. Value is language-specific.")
|
|
|
885
|
|
|
886 (defvar br-env-lang-avector
|
|
100
|
887 '[("C++/C" . "c++-")
|
|
0
|
888 ("Eiffel" . "eif-")
|
|
|
889 ("Info" . "info-")
|
|
|
890 ("Java" . "java-")
|
|
|
891 ("Lisp" . "clos-")
|
|
|
892 ("Obj-C" . "objc-")
|
|
|
893 ("Python" . "python-")
|
|
|
894 ("Smalltalk" . "smt-")]
|
|
|
895 "Association vector of (LANGUAGE-NAME . LANGUAGE-PREFIX-STRING) elements of OO-Browser languages.")
|
|
|
896
|
|
|
897 (mapcar 'br-env-lang-var (mapcar 'cdr br-env-lang-avector))
|
|
|
898
|
|
|
899 (provide 'br-env)
|
