Mercurial > hg > xemacs-beta

comparison lisp/oobr/br-lib.el @ 100:4be1180a9e89 r20-1b2

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b2
author cvs
date Mon, 13 Aug 2007 09:15:11 +0200
parents 131b0175ea99
children
comparison
equal deleted inserted replaced
99:2d83cbd90d8d 100:4be1180a9e89
4 ;; SUMMARY: OO-Browser support functions. 4 ;; SUMMARY: OO-Browser support functions.
5 ;; USAGE: GNU Emacs Lisp Library 5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: oop, tools 6 ;; KEYWORDS: oop, tools
7 ;; 7 ;;
8 ;; AUTHOR: Bob Weiner 8 ;; AUTHOR: Bob Weiner
9 ;; ORG: Motorola Inc. 9 ;; ORG: InfoDock Associates
10 ;; 10 ;;
11 ;; ORIG-DATE: 22-Mar-90 11 ;; ORIG-DATE: 22-Mar-90
12 ;; LAST-MOD: 21-Sep-95 at 14:30:36 by Bob Weiner 12 ;; LAST-MOD: 20-Feb-97 at 10:55:11 by Bob Weiner
13 ;; 13 ;;
14 ;; Copyright (C) 1990-1995 Free Software Foundation, Inc. 14 ;; Copyright (C) 1990-1997 Free Software Foundation, Inc.
15 ;; See the file BR-COPY for license information. 15 ;; See the file BR-COPY for license information.
16 ;; 16 ;;
17 ;; This file is part of the OO-Browser. 17 ;; This file is part of the OO-Browser.
18 18
19 ;;; ************************************************************************ 19 ;;; ************************************************************************
94 (setcdr lst (cdr (cdr lst))) 94 (setcdr lst (cdr (cdr lst)))
95 (setq lst (cdr lst))))) 95 (setq lst (cdr lst)))))
96 (if count (cons count sorted-strings) sorted-strings)) 96 (if count (cons count sorted-strings) sorted-strings))
97 97
98 (defun br-member-sorted-strings (elt list) 98 (defun br-member-sorted-strings (elt list)
99 "Return non-nil if ELT is an element of LIST. Comparison done with 'string-equal'. 99 "Return non-nil if ELT is an element of LIST. Comparison done with `string-equal'.
100 All ELTs must be strings and the list must be sorted in ascending order. 100 All ELTs must be strings and the list must be sorted in ascending order.
101 The value returned is actually the tail of LIST whose car is ELT." 101 The value returned is actually the tail of LIST whose car is ELT."
102 (while (and list (not (string-equal (car list) elt))) 102 (while (and list (not (string-equal (car list) elt)))
103 (setq list (and (string-lessp (car list) elt) 103 (setq list (and (string-lessp (car list) elt)
104 (cdr list)))) 104 (cdr list))))
114 (br-regexp-quote (buffer-substring (match-beginning match-num) 114 (br-regexp-quote (buffer-substring (match-beginning match-num)
115 (match-end match-num)))) 115 (match-end match-num))))
116 116
117 (defun br-rassoc (elt list) 117 (defun br-rassoc (elt list)
118 "Return non-nil if ELT is the cdr of an element of LIST. 118 "Return non-nil if ELT is the cdr of an element of LIST.
119 Comparison done with 'equal'. The value is actually the tail of LIST 119 Comparison done with `equal'. The value is actually the tail of LIST
120 starting at the element whose cdr is ELT." 120 starting at the element whose cdr is ELT."
121 (while (and list (not (equal (cdr (car list)) elt))) 121 (while (and list (not (equal (cdr (car list)) elt)))
122 (setq list (cdr list))) 122 (setq list (cdr list)))
123 list) 123 list)
124 124
136 relative-path 136 relative-path
137 filename))) 137 filename)))
138 138
139 (defmacro br-set-cons (set elt) 139 (defmacro br-set-cons (set elt)
140 "Add to SET element ELT. Returns nil iff ELT is already in SET. 140 "Add to SET element ELT. Returns nil iff ELT is already in SET.
141 Uses 'equal' for comparison." 141 Uses `equal' for comparison."
142 (` (if (br-member (, elt) (, set)) 142 (` (if (br-member (, elt) (, set))
143 nil 143 nil
144 (setq (, set) (cons (, elt) (, set)))))) 144 (setq (, set) (cons (, elt) (, set))))))
145 145
146 146
157 "Add or replace CLASS-NAME in current Environment. 157 "Add or replace CLASS-NAME in current Environment.
158 Find class source in optional CLASS-PATH. Interactively or when optional 158 Find class source in optional CLASS-PATH. Interactively or when optional
159 CLASS-PATH is nil, defaults to current buffer file as CLASS-PATH. If 159 CLASS-PATH is nil, defaults to current buffer file as CLASS-PATH. If
160 optional LIB-TABLE-P is non-nil, add to Library Environment, otherwise add to 160 optional LIB-TABLE-P is non-nil, add to Library Environment, otherwise add to
161 System Environment. If optional SAVE-FILE is t, the Environment is then 161 System Environment. If optional SAVE-FILE is t, the Environment is then
162 stored to filename given by 'br-env-file'. If SAVE-FILE is non-nil and 162 stored to filename given by `br-env-file'. If SAVE-FILE is non-nil and
163 not t, its string value is used as the file to which to save the Environment. 163 not t, its string value is used as the file to which to save the Environment.
164 Does not update children lookup table." 164 Does not update children lookup table."
165 (interactive 165 (interactive
166 (list (read-string "Class name to add: ") 166 (list (read-string "Class name to add: ")
167 (read-file-name (concat "Class file name" 167 (read-file-name (concat "Class file name"
177 ;; 177 ;;
178 ;; If class-name is in table 178 ;; If class-name is in table
179 ;; If function called interactively 179 ;; If function called interactively
180 ;; Query whether should overwrite class-name in tables 180 ;; Query whether should overwrite class-name in tables
181 ;; If yes 181 ;; If yes
182 ;; Replace entry 182 ;; Replace class and its features
183 ;; else 183 ;; else
184 ;; Don't add class; do nothing 184 ;; Don't add class; do nothing
185 ;; end 185 ;; end
186 ;; else 186 ;; else
187 ;; Store class in all necessary tables 187 ;; Store class without its features in all necessary tables
188 ;; end 188 ;; end
189 ;; else 189 ;; else
190 ;; Store class under key in all necessary tables 190 ;; Store class and its features under key in all necessary tables
191 ;; end 191 ;; end
192 ;; 192 ;;
193 (or class-path (setq class-path buffer-file-name) 193 (or class-path (setq class-path buffer-file-name)
194 (error "No class pathname specified.")) 194 (error "No class pathname specified."))
195 (if (or (string-equal class-name "") 195 (if (or (string-equal class-name "")
196 (not (or (equal class-path br-null-path) 196 (not (or (equal class-path br-null-path)
197 (file-exists-p class-path)))) 197 (file-exists-p class-path))))
198 (error (format "Invalid class specified, '%s', in: %s" class-name class-path))) 198 (error (format "Invalid class specified, `%s', in: %s" class-name class-path)))
199 ;; Is class already in Environment? 199 ;; Is class already in Environment?
200 (if (hash-key-p class-name (br-get-htable 200 (if (hash-key-p class-name (br-get-htable
201 (if lib-table-p "lib-parents" "sys-parents"))) 201 (if lib-table-p "lib-parents" "sys-parents")))
202 (if (interactive-p) 202 (if (or (not (interactive-p))
203 (if (y-or-n-p (format "Overwrite existing '%s' entry? " class-name)) 203 (y-or-n-p (format "Overwrite existing `%s' entry? " class-name)))
204 (br-real-add-class lib-table-p class-name class-path 'replace) 204 (br-real-add-class lib-table-p class-name class-path t)
205 (setq save-file nil)) 205 (setq save-file nil))
206 (br-real-add-class lib-table-p class-name class-path))
207 (br-real-add-class lib-table-p class-name class-path)) 206 (br-real-add-class lib-table-p class-name class-path))
208 (cond ((eq save-file nil)) 207 (cond ((eq save-file nil))
209 ((eq save-file t) (br-env-save)) 208 ((eq save-file t) (br-env-save))
210 ((br-env-save save-file)))) 209 ((br-env-save save-file))))
211 210
258 257
259 (defun br-class-path (class-name &optional insert) 258 (defun br-class-path (class-name &optional insert)
260 "Return full path, if any, to CLASS-NAME. 259 "Return full path, if any, to CLASS-NAME.
261 With optional prefix argument INSERT non-nil, insert path at point. 260 With optional prefix argument INSERT non-nil, insert path at point.
262 Only the first matching class is returned, so each CLASS-NAME should be 261 Only the first matching class is returned, so each CLASS-NAME should be
263 unique. Set 'br-lib/sys-search-dirs' properly before use." 262 unique. Set `br-lib/sys-search-dirs' properly before use."
264 (interactive (list (br-complete-class-name))) 263 (interactive (list (br-complete-class-name)))
265 (setq class-name (if class-name (br-set-case class-name))) 264 (setq class-name (if class-name (br-set-case class-name)))
266 (let* ((class-path) 265 (let* ((class-path)
267 (class-htable (br-get-paths-htable))) 266 (class-htable (br-get-paths-htable)))
268 (hash-map 267 (hash-map
278 (insert class-path) 277 (insert class-path)
279 (if (interactive-p) 278 (if (interactive-p)
280 (message 279 (message
281 (or class-path 280 (or class-path
282 (format 281 (format
283 "(OO-Browser): No '%s' class found in 'br-lib/sys-search-dirs'." 282 "(OO-Browser): No `%s' class found in `br-lib/sys-search-dirs'."
284 class-name))))) 283 class-name)))))
285 class-path)) 284 class-path))
286 285
287 (defun br-find-class (&optional class-name view-only other-win) 286 (defun br-find-class (&optional class-name view-only other-win)
288 "Display file of class text matching CLASS-NAME in VIEW-ONLY mode if non-nil. 287 "Display file of class text matching CLASS-NAME in VIEW-ONLY mode if non-nil.
319 (class-def (br-class-definition-regexp class-name))) 318 (class-def (br-class-definition-regexp class-name)))
320 (widen) 319 (widen)
321 (goto-char (point-min)) 320 (goto-char (point-min))
322 (if br-narrow-view-to-class 321 (if br-narrow-view-to-class
323 ;; Display file narrowed to definition of 322 ;; Display file narrowed to definition of
324 ;; 'class-name'. 323 ;; `class-name'.
325 (if (re-search-forward class-def nil t) 324 (if (re-search-forward class-def nil t)
326 ;; Narrow display to this class 325 ;; Narrow display to this class
327 (progn (narrow-to-region 326 (progn (narrow-to-region
328 (progn (setq opoint 327 (progn (setq opoint
329 (goto-char 328 (goto-char
335 (progn (br-to-class-end) 334 (progn (br-to-class-end)
336 (point))) 335 (point)))
337 (goto-char (point-min))) 336 (goto-char (point-min)))
338 (goto-char opoint) 337 (goto-char opoint)
339 (narrow-to-region pmin pmax) 338 (narrow-to-region pmin pmax)
340 (setq err (format "(OO-Browser): No '%s' in %s" class-name 339 (setq err (format "(OO-Browser): No `%s' in %s" class-name
341 class-path)) 340 class-path))
342 ) 341 )
343 (if (re-search-forward class-def nil t) 342 (if (re-search-forward class-def nil t)
344 (progn (setq opoint (goto-char (match-beginning 0))) 343 (progn (setq opoint (goto-char (match-beginning 0)))
345 (br-to-comments-begin) 344 (br-to-comments-begin)
346 (recenter 0)) 345 (recenter 0))
347 (goto-char opoint) 346 (goto-char opoint)
348 (narrow-to-region pmin pmax) 347 (narrow-to-region pmin pmax)
349 (setq err (format "(OO-Browser): No '%s' in %s" class-name 348 (setq err (format "(OO-Browser): No `%s' in %s" class-name
350 class-path)) 349 class-path))
351 ))) 350 )))
352 (setq class-path t)) 351 (setq class-path t))
353 (setq err (format "(OO-Browser): '%s' - src file not found or not readable, %s" 352 (setq err (format "(OO-Browser): `%s' - src file not found or not readable, %s"
354 class-name class-path) 353 class-name class-path)
355 class-path nil) 354 class-path nil)
356 ) 355 )
357 (if (interactive-p) 356 (if (interactive-p)
358 (setq err 357 (setq err
359 (format "(OO-Browser): No '%s' class defined in Environment." 358 (format "(OO-Browser): No `%s' class defined in Environment."
360 class-name)) 359 class-name))
361 ))) 360 )))
362 (if err (error err)) 361 (if err (error err))
363 class-path)) 362 class-path))
364 363
365 (defun br-major-mode () 364 (defun br-major-mode ()
366 "Invoke language-specific major mode on current buffer if not already set." 365 "Invoke language-specific major mode on current buffer if not already set."
367 (or (eq major-mode (symbol-function 'br-lang-mode)) 366 (or (eq major-mode (symbol-function 'br-lang-mode))
368 (br-lang-mode))) 367 (br-lang-mode)))
368
369 (defun br-scan-mode ()
370 "Invoke language-specific major mode for current buffer without running its hooks.
371 This is used when scanning source files to build Environments."
372 (let ((mode-hook-sym
373 (intern-soft (concat (symbol-name (symbol-function 'br-lang-mode))
374 "-hook"))))
375 (if mode-hook-sym
376 (eval (` (let ((, mode-hook-sym)) (br-lang-mode))))
377 (br-lang-mode))))
369 378
370 (defun br-show-children (class-name) 379 (defun br-show-children (class-name)
371 "Return children of CLASS-NAME from current Environment." 380 "Return children of CLASS-NAME from current Environment."
372 (interactive (list (br-complete-class-name t))) 381 (interactive (list (br-complete-class-name t)))
373 (and class-name 382 (and class-name
485 (or (br-class-path class) 494 (or (br-class-path class)
486 (progn 495 (progn
487 (beep) 496 (beep)
488 (message 497 (message
489 (if (br-class-in-table-p class) 498 (if (br-class-in-table-p class)
490 (format "(OO-Browser): Class '%s' referenced but not defined in Environment." 499 (format "(OO-Browser): Class `%s' referenced but not defined in Environment."
491 class) 500 class)
492 (format "(OO-Browser): Class '%s' not defined in Environment." 501 (format "(OO-Browser): Class `%s' not defined in Environment."
493 class))) 502 class)))
494 nil))) 503 nil)))
495 504
496 (defun br-check-for-class (cl &optional other-win) 505 (defun br-check-for-class (cl &optional other-win)
497 "Try to display class CL. 506 "Try to display class CL.
499 (if (br-class-in-table-p cl) 508 (if (br-class-in-table-p cl)
500 (or (br-find-class cl nil other-win) 509 (or (br-find-class cl nil other-win)
501 (progn 510 (progn
502 (beep) 511 (beep)
503 (message 512 (message
504 (format "(OO-Browser): Class '%s' referenced but not defined in Environment." 513 (format "(OO-Browser): Class `%s' referenced but not defined in Environment."
505 cl)) 514 cl))
506 t)))) 515 t))))
516
517 (defun br-delete-features (class)
518 "Delete all feature tags lexically defined in CLASS."
519 (br-feature-map-class-tags
520 (function (lambda ()
521 (beginning-of-line)
522 (delete-region (point) (progn (forward-line 1) (point)))))
523 class)
524 nil)
507 525
508 (defun br-get-children (class-name) 526 (defun br-get-children (class-name)
509 "Return list of children of CLASS-NAME from child lookup table. 527 "Return list of children of CLASS-NAME from child lookup table.
510 Those which directly inherit from CLASS-NAME." 528 Those which directly inherit from CLASS-NAME."
511 (setq class-name (and class-name (br-set-case class-name))) 529 (setq class-name (and class-name (br-set-case class-name)))
516 Those from which CLASS-NAME directly inherits." 534 Those from which CLASS-NAME directly inherits."
517 (setq class-name (and class-name (br-set-case class-name))) 535 (setq class-name (and class-name (br-set-case class-name)))
518 (br-set-of-strings (hash-get class-name (br-get-parents-htable)))) 536 (br-set-of-strings (hash-get class-name (br-get-parents-htable))))
519 537
520 (defun br-get-children-htable () 538 (defun br-get-children-htable ()
521 "Loads or builds 'br-children-htable' if necessary and returns value." 539 "Loads or builds `br-children-htable' if necessary and returns value."
522 (br-get-htable "children")) 540 (br-get-htable "children"))
523 541
524 (defun br-get-paths-htable () 542 (defun br-get-paths-htable ()
525 "Loads or builds 'br-paths-htable' if necessary and returns value." 543 "Loads or builds `br-paths-htable' if necessary and returns value."
526 (br-get-htable "paths")) 544 (br-get-htable "paths"))
527 545
528 (defun br-get-parents-htable () 546 (defun br-get-parents-htable ()
529 "Loads or builds 'br-parents-htable' if necessary and returns value." 547 "Loads or builds `br-parents-htable' if necessary and returns value."
530 (br-get-htable "parents")) 548 (br-get-htable "parents"))
531 549
532 (defun br-get-children-from-parents-htable (class-name) 550 (defun br-get-children-from-parents-htable (class-name)
533 "Return list of children of CLASS-NAME. 551 "Return list of children of CLASS-NAME.
534 Those that directly inherit from CLASS-NAME. Use parent lookup table to 552 Those that directly inherit from CLASS-NAME. Use parent lookup table to
705 (y-or-n-p (concat "Terminate all " group-descrip "? "))) 723 (y-or-n-p (concat "Terminate all " group-descrip "? ")))
706 (prog1 (mapcar 'delete-process proc-list) 724 (prog1 (mapcar 'delete-process proc-list)
707 (message "")))))) 725 (message ""))))))
708 726
709 (defun br-real-add-class (lib-table-p class-name class-path &optional replace) 727 (defun br-real-add-class (lib-table-p class-name class-path &optional replace)
710 "Add or replace class in current Environment. 728 "Add or replace class and its features within the current Environment.
711 If LIB-TABLE-P is non-nil, add to Library Environment, otherwise add to 729 If LIB-TABLE-P is non-nil, add to Library Environment, otherwise add to
712 System Environment. Add class CLASS-NAME located in CLASS-PATH to 730 System Environment. Add class CLASS-NAME located in CLASS-PATH to
713 Environment. If CLASS-PATH is nil, use current buffer file as CLASS-PATH. 731 Environment. If CLASS-PATH is nil, use current buffer file as CLASS-PATH.
714 Optional REPLACE non-nil means replace already existing class. Does not 732 Optional REPLACE non-nil means replace already existing class. Does not
715 update children lookup table." 733 update children lookup table."
732 (br-get-parents-from-source class-path class-name)))) 750 (br-get-parents-from-source class-path class-name))))
733 (setq func 'hash-add)) 751 (setq func 'hash-add))
734 ;; Signal error if class-name is invalid. 752 ;; Signal error if class-name is invalid.
735 (if (null class-name) 753 (if (null class-name)
736 (if replace 754 (if replace
737 (error "(br-real-add-class): '%s' not found in %s classes, so cannot replace it." 755 (error "(br-real-add-class): `%s' not found in %s classes, so cannot replace it."
738 class (if lib-table-p "Library" "System")) 756 class (if lib-table-p "Library" "System"))
739 (error 757 (error
740 "(br-real-add-class): Attempt to add null class to %s classes." 758 "(br-real-add-class): Attempt to add null class to %s classes."
741 (if lib-table-p "Library" "System")))) 759 (if lib-table-p "Library" "System"))))
742 ;; 760 ;;
745 (lambda (type) 763 (lambda (type)
746 (let ((par-htable (br-get-htable (concat type "parents"))) 764 (let ((par-htable (br-get-htable (concat type "parents")))
747 (path-htable (br-get-htable (concat type "paths")))) 765 (path-htable (br-get-htable (concat type "paths"))))
748 (funcall func par-list class-name par-htable) 766 (funcall func par-list class-name par-htable)
749 (br-add-to-paths-htable class-name paths-key path-htable)))) 767 (br-add-to-paths-htable class-name paths-key path-htable))))
750 (list (if lib-table-p "lib-" "sys-") "")))) 768 (list (if lib-table-p "lib-" "sys-") ""))
769 (and (stringp class-path) (file-readable-p class-path)
770 (br-get-classes-from-source class-path))))
751 771
752 (defun br-real-delete-class (class-name) 772 (defun br-real-delete-class (class-name)
753 "Delete class CLASS-NAME from current Environment. 773 "Delete class CLASS-NAME from current Environment.
754 No error occurs if the class is undefined in the Environment." 774 No error occurs if the class is undefined in the Environment."
755 (require 'set) 775 (require 'set)
776 (br-delete-features class-name)
756 (let ((paths-key (br-class-path class-name)) 777 (let ((paths-key (br-class-path class-name))
757 htable) 778 htable)
758 (setq class-name 779 (setq class-name
759 (br-first-match (concat "^" class-name "$") 780 (br-first-match (concat "^" class-name "$")
760 (hash-get paths-key (br-get-paths-htable)))) 781 (hash-get paths-key (br-get-paths-htable))))
807 (br-member class-name (car cns))) 828 (br-member class-name (car cns)))
808 (cdr cns)))) 829 (cdr cns))))
809 (br-get-parents-htable)))) 830 (br-get-parents-htable))))
810 831
811 (defun br-real-build-alists (search-dirs) 832 (defun br-real-build-alists (search-dirs)
812 "Use SEARCH-DIRS to build 'br-paths-alist' and 'br-parents-alist'." 833 "Use SEARCH-DIRS to build `br-paths-alist' and `br-parents-alist'."
813 (setq br-paths-alist nil br-parents-alist nil) 834 (setq br-paths-alist nil br-parents-alist nil)
814 (br-feature-tags-init) 835 (br-feature-tags-init)
815 (br-real-build-al search-dirs) 836 (br-real-build-al search-dirs)
816 (setq br-paths-alist br-paths-alist) 837 (setq br-paths-alist br-paths-alist)
817 (br-feature-tags-save) 838 (br-feature-tags-save)
819 840
820 (defvar br-paths-alist nil) 841 (defvar br-paths-alist nil)
821 (defvar br-parents-alist nil) 842 (defvar br-parents-alist nil)
822 843
823 (defun br-skip-dir-p (dir-name) 844 (defun br-skip-dir-p (dir-name)
824 "Returns non-nil iff DIR-NAME is matched by a member of 'br-skip-dir-regexps'." 845 "Returns non-nil iff DIR-NAME is matched by a member of `br-skip-dir-regexps'."
825 (delq nil 846 (delq nil
826 (mapcar (function 847 (mapcar (function
827 (lambda (dir-regexp) 848 (lambda (dir-regexp)
828 (string-match dir-regexp 849 (string-match dir-regexp
829 (file-name-nondirectory 850 (file-name-nondirectory
834 ;;; string. 855 ;;; string.
835 (or (fboundp 'abbreviate-file-name) 856 (or (fboundp 'abbreviate-file-name)
836 (fset 'abbreviate-file-name 'identity)) 857 (fset 'abbreviate-file-name 'identity))
837 858
838 (defun br-real-build-al (search-dirs) 859 (defun br-real-build-al (search-dirs)
839 "Descend SEARCH-DIRS and build 'br-paths-alist' and 'br-parents-alist'. 860 "Descend SEARCH-DIRS and build `br-paths-alist' and `br-parents-alist'.
840 Does not initialize 'br-paths-alist' or 'br-parents-alist' to nil." 861 Does not initialize `br-paths-alist' or `br-parents-alist' to nil."
841 (let ((inhibit-local-variables nil) 862 (let ((inhibit-local-variables nil)
842 (enable-local-variables t) 863 (enable-local-variables t)
843 (files) 864 (files)
844 ;; These are used in the 'br-search-directory' function. 865 ;; These are used in the `br-search-directory' function.
845 classes parents paths-parents-cons) 866 classes parents paths-parents-cons)
846 (mapcar 867 (mapcar
847 (function 868 (function
848 (lambda (dir) 869 (lambda (dir)
849 (if (or (null dir) (equal dir "") 870 (if (or (null dir) (equal dir "")
909 (not (file-directory-p f)) 930 (not (file-directory-p f))
910 f))) 931 f)))
911 files)))) 932 files))))
912 933
913 (defun br-real-build-parents-alist (paths-htable) 934 (defun br-real-build-parents-alist (paths-htable)
914 "Build and return 'br-parents-alist' of (parent-list . class) elements built from PATHS-HTABLE. 935 "Build and return `br-parents-alist' of (parent-list . class) elements built from PATHS-HTABLE.
915 Initializes 'br-parents-alist' to nil." 936 Initializes `br-parents-alist' to nil."
916 (let ((inhibit-local-variables nil) 937 (let ((inhibit-local-variables nil)
917 (enable-local-variables t) 938 (enable-local-variables t)
918 (br-view-file-function 'br-insert-file-contents)) 939 (br-view-file-function 'br-insert-file-contents))
919 (setq br-parents-alist nil) 940 (setq br-parents-alist nil)
920 (mapcar 941 (mapcar
939 paths-htable) 960 paths-htable)
940 br-parents-alist)) 961 br-parents-alist))
941 962
942 (defun br-set-lang-env (func sym-list val) 963 (defun br-set-lang-env (func sym-list val)
943 "Use FUNC to set each element in SYM-LIST. 964 "Use FUNC to set each element in SYM-LIST.
944 If VAL is non-nil, set 'br' element to value of current OO-Browser language 965 If VAL is non-nil, set `br' element to value of current OO-Browser language
945 element with the same name, otherwise set to symbol." 966 element with the same name, otherwise set to symbol."
946 (let ((br) (lang)) 967 (let ((br) (lang))
947 (mapcar (function 968 (mapcar (function
948 (lambda (nm) 969 (lambda (nm)
949 (setq br (intern (concat "br-" nm)) 970 (setq br (intern (concat "br-" nm))
965 "insert-class-info" "set-case" "set-case-type" 986 "insert-class-info" "set-case" "set-case-type"
966 "to-class-end" "to-comments-begin" "to-definition" 987 "to-class-end" "to-comments-begin" "to-definition"
967 "select-path" 988 "select-path"
968 989
969 "feature-implementors" "feature-locate-p" 990 "feature-implementors" "feature-locate-p"
970 "feature-name-to-regexp" "feature-signature-to-name" 991 "feature-name-to-regexp" "feature-map-class-tags"
992 "feature-signature-to-name"
971 "feature-signature-to-regexp" "feature-tag-class" 993 "feature-signature-to-regexp" "feature-tag-class"
972 "feature-tree-command-p" 994 "feature-tag-regexp" "feature-tree-command-p"
973 "list-categories" "list-features" "list-protocols" 995 "list-categories" "list-features" "list-protocols"
974 "view-friend" "view-protocol") 996 "view-friend" "view-protocol")
975 nil)) 997 nil))
976 998
977 (defun br-setup-constants () 999 (defun br-setup-constants ()
997 "List of directories below which system dirs and source files are found. 1019 "List of directories below which system dirs and source files are found.
998 A system is a group of classes that are likely to change. Value is 1020 A system is a group of classes that are likely to change. Value is
999 language-specific.") 1021 language-specific.")
1000 1022
1001 (defvar br-lib-prev-search-dirs nil 1023 (defvar br-lib-prev-search-dirs nil
1002 "Used to check if 'br-lib-paths-htable' must be regenerated. 1024 "Used to check if `br-lib-paths-htable' must be regenerated.
1003 Value is language-specific.") 1025 Value is language-specific.")
1004 (defvar br-sys-prev-search-dirs nil 1026 (defvar br-sys-prev-search-dirs nil
1005 "Used to check if 'br-sys-paths-htable' must be regenerated. 1027 "Used to check if `br-sys-paths-htable' must be regenerated.
1006 Value is language-specific.") 1028 Value is language-specific.")
1007 1029
1008 (defun br-find-file (filename &optional other-win read-only) 1030 (defun br-find-file (filename &optional other-win read-only)
1009 "Edit file FILENAME. 1031 "Edit file FILENAME.
1010 Switch to a buffer visiting file FILENAME, creating one if none 1032 Switch to a buffer visiting file FILENAME, creating one if none
1011 already exists. Optional OTHER-WIN means show in other window. 1033 already exists. Optional OTHER-WIN means show in other window.
1012 Optional READ-ONLY means make buffer read-only." 1034 Optional READ-ONLY means make buffer read-only."
1013 (interactive "FFind file: ") 1035 (interactive "FFind file: ")
1036 (if (br-in-browser)
1037 (progn (br-to-view-window)
1038 (setq other-win nil)))
1014 (funcall (if other-win 'switch-to-buffer-other-window 'switch-to-buffer) 1039 (funcall (if other-win 'switch-to-buffer-other-window 'switch-to-buffer)
1015 (find-file-noselect filename)) 1040 (find-file-noselect filename))
1016 (and read-only (setq buffer-read-only t))) 1041 (if read-only (setq buffer-read-only t)))
1017 1042
1018 (defun br-find-file-read-only (filename &optional other-win) 1043 (defun br-find-file-read-only (filename &optional other-win)
1019 "Display file FILENAME read-only. 1044 "Display file FILENAME read-only.
1020 Switch to a buffer visiting file FILENAME, creating one if none 1045 Switch to a buffer visiting file FILENAME, creating one if none
1021 already exists. Optional OTHER-WIN means show in other window." 1046 already exists. Optional OTHER-WIN means show in other window."
1037 (defvar *br-tmp-buffer* "*oobr-tmp*" 1062 (defvar *br-tmp-buffer* "*oobr-tmp*"
1038 "Name of temporary buffer used by the OO-Browser for parsing source files.") 1063 "Name of temporary buffer used by the OO-Browser for parsing source files.")
1039 1064
1040 (defun br-insert-file-contents (filename) 1065 (defun br-insert-file-contents (filename)
1041 "Insert FILENAME contents into a temporary buffer and select buffer. 1066 "Insert FILENAME contents into a temporary buffer and select buffer.
1042 Does not run any find-file hooks. Marks buffer read-only to prevent 1067 Does not run any find-file or mode specific hooks. Marks buffer read-only to
1043 any accidental editing. 1068 prevent any accidental editing.
1044 1069
1045 Set 'br-view-file-function' to this function when parsing OO-Browser source 1070 Set `br-view-file-function' to this function when parsing OO-Browser source
1046 files for fast loading of many files." 1071 files for fast loading of many files."
1047 (let ((buf (get-buffer-create *br-tmp-buffer*))) 1072 (let ((buf (get-buffer-create *br-tmp-buffer*)))
1048 (switch-to-buffer buf) 1073 (switch-to-buffer buf)
1074 ;; Don't bother saving anything for this temporary buffer
1049 (buffer-disable-undo buf) 1075 (buffer-disable-undo buf)
1050 (setq buffer-read-only nil) 1076 (setq buffer-auto-save-file-name nil
1077 buffer-read-only nil)
1051 (erase-buffer) 1078 (erase-buffer)
1052 (insert-file-contents filename t))) 1079 (insert-file-contents filename t)
1080 (br-scan-mode)
1081 (setq buffer-read-only t)))
1053 1082
1054 (defvar br-lang-prefix nil 1083 (defvar br-lang-prefix nil
1055 "Prefix string that starts language-specific symbol names.") 1084 "Prefix string that starts language-specific symbol names.")
1056 1085
1057 (defvar br-children-htable nil 1086 (defvar br-children-htable nil
1058 "Htable whose elements are of the form: (LIST-OF-CHILD-CLASSES . CLASS-NAME). 1087 "Htable whose elements are of the form: (LIST-OF-CHILD-CLASSES . CLASS-NAME).
1059 Used to traverse class inheritance graph. 'br-build-children-htable' builds 1088 Used to traverse class inheritance graph. `br-build-children-htable' builds
1060 this list. Value is language-specific.") 1089 this list. Value is language-specific.")
1061 (defvar br-parents-htable nil 1090 (defvar br-parents-htable nil
1062 "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME). 1091 "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
1063 Used to traverse class inheritance graph. 'br-build-parents-htable' builds 1092 Used to traverse class inheritance graph. `br-build-parents-htable' builds
1064 this list. Value is language-specific.") 1093 this list. Value is language-specific.")
1065 (defvar br-paths-htable nil 1094 (defvar br-paths-htable nil
1066 "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . DIRECTORY). 1095 "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . DIRECTORY).
1067 DIRECTORY gives the location of classes found in LIST-OF-CLASS-NAMES. 1096 DIRECTORY gives the location of classes found in LIST-OF-CLASS-NAMES.
1068 'br-build-paths-htable' builds this list. Value is language-specific.") 1097 `br-build-paths-htable' builds this list. Value is language-specific.")
1069 1098
1070 (defvar br-lib-parents-htable nil 1099 (defvar br-lib-parents-htable nil
1071 "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME). 1100 "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
1072 Only classes from stable software libraries are used to build the list. 1101 Only classes from stable software libraries are used to build the list.
1073 Value is language-specific.") 1102 Value is language-specific.")