|
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
|
|
|
9 ;; ORG: Motorola Inc.
|
|
|
10 ;;
|
|
|
11 ;; ORIG-DATE: 8-Jun-90
|
|
|
12 ;; LAST-MOD: 20-Sep-95 at 14:59:03 by Bob Weiner
|
|
|
13 ;;
|
|
|
14 ;; Copyright (C) 1989-1995 Free Software Foundation, Inc.
|
|
|
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
|
|
|
184 (format "Please specify the \"%s\" Environment (Hit RTN to begin)."
|
|
|
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))
|
|
|
195 (let ((prompt "System search dir #%d (RTN to end): ")
|
|
|
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)
|
|
|
209 prompt "Library search dir #%d (RTN to end): "
|
|
|
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? ")))))
|
|
|
289 nil)
|
|
|
290 (if (file-exists-p env-file)
|
|
|
291 (progn (beep)
|
|
|
292 (message "No read rights for Envir file, \"%s\"" env-file)
|
|
|
293 (sit-for 4))
|
|
|
294 (message "\"%s\", no such file." env-file)
|
|
|
295 (sit-for 2)
|
|
|
296 (setq br-loaded (br-env-load
|
|
|
297 (br-env-create env-file br-lang-prefix) t))))
|
|
|
298 br-loaded))
|
|
|
299
|
|
|
300 (defun br-env-save (&optional save-file)
|
|
|
301 "Save changed Environment to file given by optional SAVE-FILE or 'br-env-file'."
|
|
|
302 (interactive
|
|
|
303 (let ((env-file (br-env-default-file)))
|
|
|
304 (list (read-file-name
|
|
|
305 (format "Save Environment to (default \"%s\"): "
|
|
|
306 (br-relative-path env-file))
|
|
|
307 (file-name-directory env-file)
|
|
|
308 env-file nil))))
|
|
|
309 (if (and (stringp save-file)
|
|
|
310 (not (equal save-file br-env-file))
|
|
|
311 (stringp br-feature-tags-file)
|
|
|
312 (file-exists-p br-feature-tags-file))
|
|
|
313 ;; Copy feature tags file to new file name.
|
|
|
314 (copy-file br-feature-tags-file (br-feature-tags-file-name save-file)
|
|
|
315 t t))
|
|
|
316 (if (or (not (stringp save-file)) (equal save-file ""))
|
|
|
317 (setq save-file br-env-file))
|
|
|
318 (setq save-file (expand-file-name save-file))
|
|
|
319 (or (file-writable-p save-file)
|
|
|
320 (error (format "Non-writable Environment file, \"%s\""
|
|
|
321 save-file)))
|
|
|
322 (let ((buf (get-file-buffer save-file)))
|
|
|
323 (and buf (kill-buffer buf)))
|
|
|
324 (let ((dir (or (file-name-directory save-file)
|
|
|
325 default-directory)))
|
|
|
326 (or (file-writable-p dir)
|
|
|
327 (error (format "Non-writable Environment directory, \"%s\"" dir))))
|
|
|
328 (save-window-excursion
|
|
|
329 (let ((standard-output
|
|
|
330 (set-buffer (funcall br-find-file-noselect-function
|
|
|
331 save-file)))
|
|
|
332 (buffer-read-only)
|
|
|
333 br-sym)
|
|
|
334 (erase-buffer)
|
|
|
335 (princ "\n(setq\nbr-env-version")
|
|
|
336 (print br-version)
|
|
|
337 (br-env-save-mult-vars (cons (car br-env-mult-vars) nil))
|
|
|
338 (mapcar (function
|
|
|
339 (lambda (nm)
|
|
|
340 (setq br-sym (intern-soft (concat "br-" nm)))
|
|
|
341 (let ((nm-mid (string-match "-htable$" nm)))
|
|
|
342 (if nm-mid
|
|
|
343 (progn (princ "\nbr-") (princ (substring nm 0 nm-mid))
|
|
|
344 (princ "-alist\n'")
|
|
|
345 (hash-prin1 (symbol-value br-sym)))
|
|
|
346 (princ "\n") (princ br-sym) (princ "\n'")
|
|
|
347 (prin1 (symbol-value br-sym)) (princ "\n")))))
|
|
|
348 br-env-single-vars)
|
|
|
349 (br-env-save-mult-vars (cdr br-env-mult-vars))
|
|
|
350 (princ ")\n")
|
|
|
351 (save-buffer)
|
|
|
352 (kill-buffer standard-output))))
|
|
|
353
|
|
|
354 (defun br-env-stats (&optional arg)
|
|
|
355 "Display summary for current Environment in viewer window.
|
|
|
356 With optional prefix ARG, display class totals in minibuffer."
|
|
|
357 (interactive "P")
|
|
|
358 (let ((env-file (abbreviate-file-name br-env-file)))
|
|
|
359 (if arg
|
|
|
360 (message "Envir \"%s\": %s" env-file (br-env-totals))
|
|
|
361 (br-funcall-in-view-window
|
|
|
362 (concat br-buffer-prefix-info "Info")
|
|
|
363 (function
|
|
|
364 (lambda ()
|
|
|
365 (insert (format "Environment: \"%s\"" env-file))
|
|
|
366 (center-line)
|
|
|
367 (insert "\n\n")
|
|
|
368 (if (null br-env-spec)
|
|
|
369 (insert (format "Built by version %s of the OO-Browser.\n\n"
|
|
|
370 (or br-env-version "earlier than 02.09.03"))))
|
|
|
371 (insert (br-env-totals) "\n\n")
|
|
|
372 (let ((undefined (br-undefined-classes)))
|
|
|
373 (if undefined
|
|
|
374 (insert (format "Undefined classes: %s\n\n" undefined))))
|
|
|
375 (mapcar
|
|
|
376 (function
|
|
|
377 (lambda (sys-lib)
|
|
|
378 (insert (format "Directories to search for %s classes:\n"
|
|
|
379 (car sys-lib)))
|
|
|
380 (if (cdr sys-lib)
|
|
|
381 (progn (mapcar
|
|
|
382 (function
|
|
|
383 (lambda (dir)
|
|
|
384 (or (equal dir "")
|
|
|
385 (insert
|
|
|
386 (format "\t%s\n"
|
|
|
387 (abbreviate-file-name dir))))))
|
|
|
388 (cdr sys-lib))
|
|
|
389 (insert "\n"))
|
|
|
390 (insert "\t<None>\n\n"))))
|
|
|
391 (list (cons "System" br-sys-search-dirs)
|
|
|
392 (cons "Library" br-lib-search-dirs)))
|
|
|
393 (insert "Flag Settings:"
|
|
|
394 "\n\tEnvironment built from specification: "
|
|
|
395 (if br-env-spec "no" "yes")
|
|
|
396 "\n")
|
|
|
397 (set-buffer-modified-p nil)))))))
|
|
|
398
|
|
|
399 ;;; ************************************************************************
|
|
|
400 ;;; Private functions
|
|
|
401 ;;; ************************************************************************
|
|
|
402
|
|
|
403 (defun br-env-add-ref-classes (&optional htable-type)
|
|
|
404 "Add classes to Environment which are referenced in it but not defined.
|
|
|
405 With optional HTABLE-TYPE, affect only that part of the Environment.
|
|
|
406 HTABLE-TYPE may be \"sys\"or \"lib\". By default, add to both Library and
|
|
|
407 whole Environment tables."
|
|
|
408 ;;
|
|
|
409 ;; This function must NOT call any 'get-htable' type functions or it will
|
|
|
410 ;; cause an infinite loop.
|
|
|
411 (let ((classes (br-all-classes
|
|
|
412 (symbol-value
|
|
|
413 (intern-soft (concat "br-" htable-type
|
|
|
414 (if htable-type "-")
|
|
|
415 "paths-htable")))))
|
|
|
416 (pars (br-env-all-parents
|
|
|
417 (symbol-value
|
|
|
418 (intern-soft (concat "br-" htable-type
|
|
|
419 (if htable-type "-")
|
|
|
420 "parents-htable")))))
|
|
|
421 (class))
|
|
|
422 (while pars
|
|
|
423 (setq class (car pars)
|
|
|
424 pars (cdr pars))
|
|
|
425 (if (or (null class) (br-member class classes))
|
|
|
426 nil
|
|
|
427 (setq classes (cons class classes))
|
|
|
428 (if (null htable-type) (setq htable-type "lib"))
|
|
|
429 (br-env-add-to-htables class (concat htable-type "-parents"))
|
|
|
430 (br-add-to-paths-htable
|
|
|
431 class br-null-path
|
|
|
432 (br-get-htable (concat htable-type "-paths")))))))
|
|
|
433
|
|
|
434 (defun br-env-add-to-htables (class parents)
|
|
|
435 "Add CLASS to hash tables referenced by PARENTS name.
|
|
|
436 PARENTS may be \"parents\", \"sys-parents\", or \"lib-parents\"."
|
|
|
437 (if (null class)
|
|
|
438 nil
|
|
|
439 (setq parents
|
|
|
440 (symbol-value (intern-soft (concat "br-" parents "-htable"))))
|
|
|
441 (if parents (hash-add nil class parents))))
|
|
|
442
|
|
|
443 (defun br-env-all-parents (&optional htable-type)
|
|
|
444 "Return list of all parent names in Environment or optional HTABLE-TYPE.
|
|
|
445 HTABLE-TYPE may be \"sys\" or \"lib\". or an actual hash table."
|
|
|
446 (apply 'append
|
|
|
447 (hash-map 'car
|
|
|
448 (cond ((and (stringp htable-type)
|
|
|
449 (not (string-equal htable-type "")))
|
|
|
450 (br-get-htable (concat htable-type "-parents")))
|
|
|
451 ((hashp htable-type) htable-type)
|
|
|
452 (t (br-get-parents-htable))))))
|
|
|
453
|
|
|
454 (defun br-env-batch-build ()
|
|
|
455 "Build Environments from specifications while running Emacs in batch mode.
|
|
|
456 Invoke via a shell command line of the following form:
|
|
|
457 emacs -batch -l <BR-DIR>/br-start.el <OO-Browser Env Spec File> ... <Spec File> -f br-env-batch-build"
|
|
|
458 (br-init-autoloads)
|
|
|
459 (if (or (not (boundp 'br-directory)) (null br-directory)
|
|
|
460 (not (file-exists-p br-directory)))
|
|
|
461 (error "br-env-batch-build: Set 'br-directory' properly before use.")
|
|
|
462 (let ((spec-file)
|
|
|
463 (files (delq nil (mapcar 'buffer-file-name (buffer-list)))))
|
|
|
464 (while (setq spec-file (car files))
|
|
|
465 (setq files (cdr files))
|
|
|
466 (load spec-file)
|
|
|
467 (or (featurep (intern-soft (concat br-lang-prefix "browse")))
|
|
|
468 (featurep (intern-soft (concat br-lang-prefix "brows")))
|
|
|
469 (load (expand-file-name
|
|
|
470 (concat br-lang-prefix "browse") br-directory)
|
|
|
471 t)
|
|
|
472 (load (expand-file-name
|
|
|
473 (concat br-lang-prefix "brows") br-directory)))
|
|
|
474 (funcall (intern (concat br-lang-prefix "browse-setup")))
|
|
|
475 (kill-buffer nil)
|
|
|
476 (br-env-build spec-file nil)))))
|
|
|
477
|
|
|
478 ;;; The following function is called by the compilation sentinel whenever a
|
|
|
479 ;;; compilation finishes under versions of Emacs 19. (If you use Emacs 18,
|
|
|
480 ;;; you would have to edit compilation-sentinel to call the function stored
|
|
|
481 ;;; in 'compilation-finish-function' as Emacs 19, compile.el does.
|
|
|
482 ;;;
|
|
|
483 ;;; If there already is a compilation-finish-function, save it and use it
|
|
|
484 ;;; when not in a batch environment build.
|
|
|
485 (setq compilation-original-finish-function
|
|
|
486 (and (boundp 'compilation-finish-function)
|
|
|
487 (not (eq compilation-finish-function 'br-env-batch-build-browse))
|
|
|
488 compilation-finish-function)
|
|
|
489 compilation-finish-function 'br-env-batch-build-browse)
|
|
|
490
|
|
|
491 (defun br-env-batch-build-browse (&rest args)
|
|
|
492 ;; This is only called when we are in the compilation buffer already.
|
|
|
493 (cond ((not (string-match "oobr-env" compile-command))
|
|
|
494 ;; Some other type of build.
|
|
|
495 (if compilation-original-finish-function
|
|
|
496 (apply compilation-original-finish-function args)))
|
|
|
497 ((not (and (stringp mode-line-process)
|
|
|
498 (string-match "OK" mode-line-process)))
|
|
|
499 ;; Build failed.
|
|
|
500 nil)
|
|
|
501 (t ;; Environment build was successful.
|
|
|
502 (beep)
|
|
|
503 (let* ((env-file (getenv "OOBR_ENV"))
|
|
|
504 (prompt
|
|
|
505 (format
|
|
|
506 "(OO-Browser): Environment \"%s\" is built; browse it now? "
|
|
|
507 (file-name-nondirectory env-file))))
|
|
|
508 (if (y-or-n-p prompt)
|
|
|
509 (br-env-browse env-file))))))
|
|
|
510
|
|
|
511 (defun br-env-cond-build (env-file prompt)
|
|
|
512 "Build current Environment from its specification and save it in ENV-FILE.
|
|
|
513 Non-nil PROMPT is used to prompt user before building Environment. Return t
|
|
|
514 iff current Environment gets built from specification."
|
|
|
515 (let ((dir (or (file-name-directory env-file)
|
|
|
516 default-directory)))
|
|
|
517 (if (not (file-writable-p dir))
|
|
|
518 (progn (beep)
|
|
|
519 (message "Unwritable Environment directory, \"%s\"" dir)
|
|
|
520 (sit-for 4) nil)
|
|
|
521 (if (or (not prompt)
|
|
|
522 (y-or-n-p (format prompt env-file)))
|
|
|
523 (progn (br-env-build env-file 'prompt) t)))))
|
|
|
524
|
|
|
525 (defun br-env-copy (to-br)
|
|
|
526 "Copy 'br-' Environment to or from 'br-lang-prefix' language variables.
|
|
|
527 If TO-BR is non-nil, copy from language-specific variables to browser
|
|
|
528 variables. Otherwise, do copy in the reverse direction."
|
|
|
529 (let* ((var1) (var2)
|
|
|
530 (copy-func
|
|
|
531 (if to-br (function (lambda () (set var1 (symbol-value var2))))
|
|
|
532 (function (lambda () (set var2 (symbol-value var1)))))))
|
|
|
533 (mapcar (function
|
|
|
534 (lambda (nm)
|
|
|
535 (setq var1 (intern (concat "br-" nm))
|
|
|
536 var2 (intern (concat br-lang-prefix nm)))
|
|
|
537 (funcall copy-func)))
|
|
|
538 (append
|
|
|
539 '("env-file" "env-version" "lib-search-dirs"
|
|
|
540 "lib-prev-search-dirs" "lib-parents-htable"
|
|
|
541 "lib-paths-htable" "sys-search-dirs"
|
|
|
542 "sys-prev-search-dirs" "sys-parents-htable"
|
|
|
543 "sys-paths-htable" "paths-htable" "parents-htable")
|
|
|
544 br-env-single-vars))))
|
|
|
545
|
|
|
546 (defun br-env-create-alists ()
|
|
|
547 "Create all empty Environment association lists."
|
|
|
548 (setq br-children-alist nil
|
|
|
549 br-sys-paths-alist nil br-lib-paths-alist nil
|
|
|
550 br-sys-parents-alist nil br-lib-parents-alist nil
|
|
|
551 br-paths-alist nil br-parents-alist nil))
|
|
|
552
|
|
|
553 (defun br-env-create-htables ()
|
|
|
554 "Create all empty Environment hash tables."
|
|
|
555 (setq br-children-htable (hash-make 0)
|
|
|
556 br-sys-paths-htable (hash-make 0)
|
|
|
557 br-sys-parents-htable (hash-make 0)
|
|
|
558 br-lib-paths-htable (hash-make 0)
|
|
|
559 br-lib-parents-htable (hash-make 0)
|
|
|
560 br-paths-htable (hash-make 0)
|
|
|
561 br-parents-htable (hash-make 0)))
|
|
|
562
|
|
|
563 (defun br-env-default-file (&optional directory)
|
|
|
564 "Search up current or optional DIRECTORY tree for an OO-Browser environment file.
|
|
|
565 Return file name found, the value of 'br-env-file' if non-nil, or else the
|
|
|
566 value of 'br-env-default-file'. All return values are expanded to absolute
|
|
|
567 paths before being returned."
|
|
|
568 (let ((path directory)
|
|
|
569 (oobr-file))
|
|
|
570 (while (and (stringp path)
|
|
|
571 (setq path (file-name-directory path))
|
|
|
572 (setq path (directory-file-name path))
|
|
|
573 ;; Not at root directory
|
|
|
574 (not (string-match ":?/\\'" path))
|
|
|
575 ;; No environment file
|
|
|
576 (not (file-exists-p
|
|
|
577 (setq oobr-file (expand-file-name
|
|
|
578 br-env-default-file path)))))
|
|
|
579 (setq oobr-file nil))
|
|
|
580 (expand-file-name (or oobr-file br-env-file br-env-default-file))))
|
|
|
581
|
|
|
582 (defun br-env-file-sym-val (symbol-name)
|
|
|
583 "Given a SYMBOL-NAME, a string, find its value in the current Environment file.
|
|
|
584 Assume the Environment file to use is attached to the current buffer.
|
|
|
585 Only search for the SYMBOL-NAME from the current point in the buffer.
|
|
|
586 Return cons whose car is t iff SYMBOL-NAME was found and then whose cdr is the
|
|
|
587 non-quoted value found."
|
|
|
588 (set-buffer (funcall br-find-file-noselect-function br-env-file))
|
|
|
589 (save-excursion
|
|
|
590 (if (search-forward symbol-name nil t)
|
|
|
591 (let ((standard-input (current-buffer)))
|
|
|
592 (cons t (eval (read)))))))
|
|
|
593
|
|
|
594 (defun br-env-try-load (env-file default-file)
|
|
|
595 "Try to load a complete Environment, initially given by ENV-FILE.
|
|
|
596 If an Environment specification is selected, the user will be prompted
|
|
|
597 whether or not to build it. If ENV-FILE is not a string, the function will
|
|
|
598 prompt for an Environment to load. DEFAULT-FILE is the default file to use
|
|
|
599 when an empty value is given at the Environment file prompt.
|
|
|
600
|
|
|
601 Return the name of the Environment file that was loaded or nil."
|
|
|
602 (if (br-env-load
|
|
|
603 (if (stringp env-file)
|
|
|
604 env-file
|
|
|
605 (or (stringp default-file)
|
|
|
606 (setq default-file (br-env-default-file)))
|
|
|
607 (setq env-file
|
|
|
608 (read-file-name
|
|
|
609 (format
|
|
|
610 "OO-Browser Environment file (default \"%s\"): "
|
|
|
611 (br-relative-path default-file))
|
|
|
612 nil
|
|
|
613 default-file nil)))
|
|
|
614 'prompt)
|
|
|
615 (if (stringp env-file)
|
|
|
616 (setq br-env-file (expand-file-name env-file)))))
|
|
|
617
|
|
|
618 (defun br-env-get-dirs (prompt)
|
|
|
619 "PROMPT for and return list of directory names.
|
|
|
620 PROMPT must contain a %d somewhere in it, so dir # may be inserted."
|
|
|
621 (let ((dir) (dirs) (num 1) (default ""))
|
|
|
622 (while (not (string-equal "" (setq dir (read-file-name
|
|
|
623 (format prompt num) default "" t))))
|
|
|
624 (if (file-directory-p dir)
|
|
|
625 (setq dirs (cons dir dirs)
|
|
|
626 num (1+ num)
|
|
|
627 default "")
|
|
|
628 (beep)
|
|
|
629 (setq default dir)))
|
|
|
630 (nreverse dirs)))
|
|
|
631
|
|
|
632 (defun br-env-init (env-file same-lang same-env)
|
|
|
633 "Load or build ENV-FILE if non-nil.
|
|
|
634 Otherwise, use 'br-env-file' if non-nil or if not, interactively prompt for
|
|
|
635 Environment name. SAME-LANG should be non-nil if invoking the OO-Browser on
|
|
|
636 the same language again. SAME-ENV should be non-nil if invoking the
|
|
|
637 OO-Browser on the same Environment again. br-sys/lib-search-dirs variables
|
|
|
638 should be set before this function is called.
|
|
|
639
|
|
|
640 Return the name of the current Environment file unless load attempt fails,
|
|
|
641 then return nil."
|
|
|
642 (cond
|
|
|
643
|
|
|
644 ;; Specific environment requested
|
|
|
645 (env-file
|
|
|
646 ;; Create or load spec and load or build Environment
|
|
|
647 (setq env-file (br-env-try-load env-file br-env-file)))
|
|
|
648
|
|
|
649 ;; First invocation on this lang
|
|
|
650 ((and (null br-sys-search-dirs) (null br-lib-search-dirs))
|
|
|
651 ;; Create or load spec and load or build Environment
|
|
|
652 (setq env-file
|
|
|
653 (br-env-try-load (or br-env-file (br-env-create)) br-env-file)))
|
|
|
654
|
|
|
655 ;; Non-first invocation, search paths have been set, possibly default Env
|
|
|
656 (t
|
|
|
657 (setq env-file br-env-file)
|
|
|
658 (cond
|
|
|
659 ;; Continue browsing an Environment
|
|
|
660 (same-env nil)
|
|
|
661 (same-lang
|
|
|
662 ;; But search paths have changed, so rebuild Env
|
|
|
663 (progn (or (eq br-sys-search-dirs br-sys-prev-search-dirs)
|
|
|
664 (br-build-sys-htable))
|
|
|
665 (or (eq br-lib-search-dirs br-lib-prev-search-dirs)
|
|
|
666 (br-build-lib-htable))))
|
|
|
667 ;; Request to browse a different language Env
|
|
|
668 (t
|
|
|
669 (setq env-file (br-env-try-load
|
|
|
670 (or br-env-file (br-env-create)) br-env-file))))))
|
|
|
671 ;; Return current Env file name unless load attempt failed, then return nil.
|
|
|
672 env-file)
|
|
|
673
|
|
|
674 (defun *br-env-internal-structures* ()
|
|
|
675 "Display values of internal data structures in viewer buffer."
|
|
|
676 (interactive)
|
|
|
677 (br-funcall-in-view-window
|
|
|
678 (concat br-buffer-prefix-info "Info")
|
|
|
679 (function
|
|
|
680 (lambda ()
|
|
|
681 (let ((standard-output (current-buffer)))
|
|
|
682 (mapcar
|
|
|
683 (function
|
|
|
684 (lambda (sym)
|
|
|
685 (mapcar
|
|
|
686 (function (lambda (obj)
|
|
|
687 (princ obj)))
|
|
|
688 (list "!!! " (symbol-name sym) " !!!\n\n"
|
|
|
689 (symbol-value sym) "\n \n"))
|
|
|
690 ))
|
|
|
691 '(br-children-htable
|
|
|
692 br-parents-htable
|
|
|
693 br-paths-htable
|
|
|
694 br-sys-search-dirs
|
|
|
695 br-sys-paths-htable
|
|
|
696 br-sys-parents-htable
|
|
|
697 br-lib-search-dirs
|
|
|
698 br-lib-paths-htable
|
|
|
699 br-lib-parents-htable
|
|
|
700 br-lang-prefix
|
|
|
701 br-env-spec)))))))
|
|
|
702
|
|
|
703 (defun br-env-lang-dialog-box (dialog-box)
|
|
|
704 "Prompt user with DIALOG-BOX and return selected value.
|
|
|
705 Assumes caller has checked that 'dialog-box' function exists."
|
|
|
706 (let ((echo-keystrokes 0)
|
|
|
707 event-obj
|
|
|
708 event)
|
|
|
709 ;; Add a cancel button to dialog box.
|
|
|
710 (setq dialog-box (append dialog-box (list nil '["Cancel" abort t])))
|
|
|
711 (popup-dialog-box dialog-box)
|
|
|
712 (catch 'br-env-done
|
|
|
713 (while t
|
|
|
714 (setq event (next-command-event event)
|
|
|
715 event-obj (event-object event))
|
|
|
716 (cond ((and (menu-event-p event)
|
|
|
717 (memq event-obj '(abort menu-no-selection-hook)))
|
|
|
718 (signal 'quit nil))
|
|
|
719 ((button-release-event-p event) ;; don't beep twice
|
|
|
720 nil)
|
|
|
721 ((menu-event-p event)
|
|
|
722 (throw 'br-env-done (eval event-obj)))
|
|
|
723 (t
|
|
|
724 (beep)
|
|
|
725 (message "Please answer the dialog box.")))))))
|
|
|
726
|
|
|
727 (defun br-env-lang-var (lang-prefix)
|
|
|
728 "Create language-specific Environment variables for LANG-PREFIX."
|
|
|
729 (eval (list 'defvar (intern (concat lang-prefix "env-version"))
|
|
|
730 nil
|
|
|
731 "Version of the OO-Browser used to build the current Environment or nil."))
|
|
|
732 (eval (list 'defvar (intern (concat lang-prefix "env-file"))
|
|
|
733 br-env-default-file
|
|
|
734 "*File in which to save Environment.")))
|
|
|
735
|
|
|
736 (defun br-env-load-matching-htables (changed-types-list)
|
|
|
737 (let ((still-changed-types))
|
|
|
738 (if (file-readable-p br-env-file)
|
|
|
739 (unwind-protect
|
|
|
740 (progn
|
|
|
741 (let ((buf (get-file-buffer br-env-file)))
|
|
|
742 (and buf (kill-buffer buf)))
|
|
|
743 (set-buffer (funcall br-find-file-noselect-function br-env-file))
|
|
|
744 (goto-char (point-min))
|
|
|
745 (mapcar
|
|
|
746 (function
|
|
|
747 (lambda (type)
|
|
|
748 (let* ((search-dirs (concat "br-" type "-search-dirs"))
|
|
|
749 (prev-dirs (concat "br-" type "-prev-search-dirs"))
|
|
|
750 (paths (concat "br-" type "-paths-htable"))
|
|
|
751 (parents (concat "br-" type "-parents-htable"))
|
|
|
752 (dirs-val (cdr (br-env-file-sym-val search-dirs))))
|
|
|
753 (if (equal dirs-val (symbol-value (intern search-dirs)))
|
|
|
754 (and (br-member type changed-types-list)
|
|
|
755 (progn (set (intern paths)
|
|
|
756 (cdr (br-env-file-sym-val paths)))
|
|
|
757 (set (intern parents)
|
|
|
758 (cdr (br-env-file-sym-val parents)))
|
|
|
759 (set (intern prev-dirs)
|
|
|
760 (symbol-value
|
|
|
761 (intern search-dirs)))))
|
|
|
762 (setq still-changed-types
|
|
|
763 (cons type still-changed-types))))))
|
|
|
764 '("sys" "lib"))
|
|
|
765 )
|
|
|
766 nil))
|
|
|
767 (nreverse still-changed-types)))
|
|
|
768
|
|
|
769 (defun br-env-save-mult-vars (mult-vars)
|
|
|
770 (let ((br-sym))
|
|
|
771 (mapcar
|
|
|
772 (function
|
|
|
773 (lambda (suffix)
|
|
|
774 (mapcar
|
|
|
775 (function
|
|
|
776 (lambda (type-str)
|
|
|
777 (setq br-sym (intern-soft
|
|
|
778 (concat "br-" type-str suffix)))
|
|
|
779 (if (and br-sym (boundp br-sym))
|
|
|
780 (let* ((nm (symbol-name br-sym))
|
|
|
781 (nm-mid (string-match "-htable$" nm)))
|
|
|
782 (if nm-mid
|
|
|
783 (progn (princ "\n") (princ (substring nm 0 nm-mid))
|
|
|
784 (princ "-alist\n'")
|
|
|
785 (hash-prin1 (symbol-value br-sym)))
|
|
|
786 (princ "\n") (princ br-sym) (princ "\n'")
|
|
|
787 (prin1 (symbol-value br-sym))
|
|
|
788 (princ "\n"))))))
|
|
|
789 '("sys-" "lib-"))))
|
|
|
790 mult-vars)))
|
|
|
791
|
|
|
792 (defun br-env-set-htables ()
|
|
|
793 (br-env-add-ref-classes "lib")
|
|
|
794 (br-env-add-ref-classes "sys")
|
|
|
795 ;; Make System entries override Library entries which they duplicate, since
|
|
|
796 ;; this is generally more desireable than merging the two. Don't do this
|
|
|
797 ;; for the paths-htable, however, since the value is the union of both
|
|
|
798 ;; values.
|
|
|
799 (setq br-paths-htable (hash-merge br-sys-paths-htable br-lib-paths-htable))
|
|
|
800 (let ((hash-merge-values-function (function (lambda (val1 val2) val1))))
|
|
|
801 (setq br-parents-htable (hash-merge br-sys-parents-htable
|
|
|
802 br-lib-parents-htable))))
|
|
|
803
|
|
|
804 (defun br-env-select-lang ()
|
|
|
805 "Interactively select and return value for 'br-lang-prefix'."
|
|
|
806 (let ((n 0) (nlangs (length br-env-lang-avector))
|
|
|
807 (lang-prompt)
|
|
|
808 ;; Use dialog box if last user event involved the mouse.
|
|
|
809 (use-dialog-box (and (fboundp 'popup-dialog-box)
|
|
|
810 (fboundp 'button-press-event-p)
|
|
|
811 (or (button-press-event-p last-command-event)
|
|
|
812 (button-release-event-p last-command-event)
|
|
|
813 (menu-event-p last-command-event)))))
|
|
|
814 ;; Create a prompt numbering each OO-Browser language available.
|
|
|
815 (setq lang-prompt
|
|
|
816 (if use-dialog-box
|
|
|
817 (mapcar
|
|
|
818 (function (lambda (lang)
|
|
|
819 (setq n (1+ n))
|
|
|
820 (vector lang (list 'identity n) 't)))
|
|
|
821 (mapcar 'car br-env-lang-avector))
|
|
|
822 (mapconcat
|
|
|
823 (function (lambda (lang)
|
|
|
824 (setq n (1+ n))
|
|
|
825 (format "%d\) %s" n lang)))
|
|
|
826 (mapcar 'car br-env-lang-avector)
|
|
|
827 "; ")))
|
|
|
828 ;; Prompt user.
|
|
|
829 (while (progn
|
|
|
830 (setq n (if use-dialog-box
|
|
|
831 (br-env-lang-dialog-box
|
|
|
832 (cons "Choose language to browse: " lang-prompt))
|
|
|
833 ;; Otherwise, prompt in the minibuffer.
|
|
|
834 (string-to-int
|
|
|
835 (read-string (concat "Choose: " lang-prompt ": ") ""))))
|
|
|
836 (or (< n 1) (> n nlangs)))
|
|
|
837 (beep))
|
|
|
838 (cdr (aref br-env-lang-avector (1- n)))))
|
|
|
839
|
|
|
840 (defun br-env-totals ()
|
|
|
841 "Return string of Environment class totals."
|
|
|
842 (let ((sys (length (br-all-classes "sys")))
|
|
|
843 (lib (length (br-all-classes "lib")))
|
|
|
844 (duplicates (car (br-all-classes nil t)))
|
|
|
845 count)
|
|
|
846 (format "%sTotal unique classes: %d; System: %d; Library: %d"
|
|
|
847 (if (null duplicates)
|
|
|
848 ""
|
|
|
849 (setq count (length duplicates))
|
|
|
850 (format "%d DUPLICATE CLASS%s TO CONSIDER ELIMINATING:\n\t%s\n\n"
|
|
|
851 count (if (= count 1) "" "ES") duplicates))
|
|
|
852 (+ sys lib) sys lib)))
|
|
|
853
|
|
|
854 ;;; ************************************************************************
|
|
|
855 ;;; Internal variables
|
|
|
856 ;;; ************************************************************************
|
|
|
857
|
|
|
858 (defvar br-env-version nil
|
|
|
859 "Version of the OO-Browser used to build the current Environment or nil.")
|
|
|
860
|
|
|
861 (defconst br-env-mult-vars
|
|
|
862 '("search-dirs" "paths-htable" "parents-htable")
|
|
|
863 "Descriptors of multiple copy variables saved as part of an Environment.")
|
|
|
864 (defconst br-env-single-vars
|
|
|
865 '("lang-prefix" "env-spec" "children-htable")
|
|
|
866 "Descriptors of singular variables saved as part of an Environment.")
|
|
|
867
|
|
|
868 (defvar br-env-spec nil
|
|
|
869 "Non-nil value means Environment specification has been given but not yet built.
|
|
|
870 Nil means current Environment has been built, though it may still require
|
|
|
871 updating. Value is language-specific.")
|
|
|
872
|
|
|
873 (defvar br-env-lang-avector
|
|
|
874 '[("C++" . "c++-")
|
|
|
875 ("Eiffel" . "eif-")
|
|
|
876 ("Info" . "info-")
|
|
|
877 ("Java" . "java-")
|
|
|
878 ("Lisp" . "clos-")
|
|
|
879 ("Obj-C" . "objc-")
|
|
|
880 ("Python" . "python-")
|
|
|
881 ("Smalltalk" . "smt-")]
|
|
|
882 "Association vector of (LANGUAGE-NAME . LANGUAGE-PREFIX-STRING) elements of OO-Browser languages.")
|
|
|
883
|
|
|
884 (mapcar 'br-env-lang-var (mapcar 'cdr br-env-lang-avector))
|
|
|
885
|
|
|
886 (provide 'br-env)
|
