Mercurial > hg > xemacs-beta

comparison lisp/oobr/br-env.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 4103f0995bd7
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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)