Mercurial > hg > xemacs-beta
comparison lisp/oobr/br-lib.el @ 0:376386a54a3c r19-14
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-lib.el | |
| 4 ;; SUMMARY: OO-Browser 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: 22-Mar-90 | |
| 12 ;; LAST-MOD: 21-Sep-95 at 14:30:36 by Bob Weiner | |
| 13 ;; | |
| 14 ;; Copyright (C) 1990-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 (mapcar 'require '(br-env br-ftr br-compl set)) | |
| 24 | |
| 25 ;;; ************************************************************************ | |
| 26 ;;; Public variables | |
| 27 ;;; ************************************************************************ | |
| 28 | |
| 29 (defvar br-null-path "<none>" | |
| 30 "Pathname associated with OO-Browser entities which have no source file. | |
| 31 That is, virtual entities, such as categories.") | |
| 32 | |
| 33 ;;; ************************************************************************ | |
| 34 ;;; General public functions | |
| 35 ;;; ************************************************************************ | |
| 36 | |
| 37 (defun br-buffer-replace (regexp to-str) | |
| 38 "In current buffer, replace all occurrences of REGEXP with TO-STR." | |
| 39 (goto-char (point-min)) | |
| 40 (while (re-search-forward regexp nil t) | |
| 41 (replace-match to-str 'fixedcase nil) | |
| 42 (backward-char 1))) | |
| 43 | |
| 44 (defun br-delete-space (string) | |
| 45 "Delete any leading and trailing space from STRING and return the STRING. " | |
| 46 (if (string-match "\\`\\s *\\(\\(.\\|\n\\)*\\S \\)\\s *\\'" string) | |
| 47 (setq string (substring string (match-beginning 1) | |
| 48 (match-end 1))) | |
| 49 string)) | |
| 50 | |
| 51 (defun br-first-match (regexp list) | |
| 52 "Return non-nil if REGEXP matches to an element of LIST. | |
| 53 All elements of LIST must be strings. | |
| 54 The value returned is the first matched element." | |
| 55 (while (and list (not (string-match regexp (car list)))) | |
| 56 (setq list (cdr list))) | |
| 57 (car list)) | |
| 58 | |
| 59 (defun br-filename-head (path) | |
| 60 (setq path (file-name-nondirectory path)) | |
| 61 (if (string-match "\\(.+\\)\\." path) | |
| 62 (substring path 0 (match-end 1)) | |
| 63 path)) | |
| 64 | |
| 65 (defun br-duplicate-and-unique-strings (sorted-strings) | |
| 66 "Return SORTED-STRINGS list with a list of duplicate entries consed onto the front of the list." | |
| 67 (let ((elt1) (elt2) (lst sorted-strings) | |
| 68 (count 0) (repeat) (duplicates)) | |
| 69 (while (setq elt1 (car lst) elt2 (car (cdr lst))) | |
| 70 (cond ((not (string-equal elt1 elt2)) | |
| 71 (setq lst (cdr lst))) | |
| 72 ((equal elt1 repeat) | |
| 73 ;; Already recorded this duplicate. | |
| 74 (setcdr lst (cdr (cdr lst)))) | |
| 75 (t ;; new duplicate | |
| 76 (setq count (1+ count) | |
| 77 duplicates (cons elt1 duplicates) | |
| 78 repeat elt1) | |
| 79 (setcdr lst (cdr (cdr lst)))))) | |
| 80 (cons (sort duplicates 'string-lessp) sorted-strings))) | |
| 81 | |
| 82 (defun br-set-of-strings (sorted-strings &optional count) | |
| 83 "Return SORTED-STRINGS list with any duplicate entries removed. | |
| 84 Optional COUNT conses number of duplicates on to front of list before return." | |
| 85 (and count (setq count 0)) | |
| 86 (let ((elt1) (elt2) (lst sorted-strings) | |
| 87 (test (if count | |
| 88 (function | |
| 89 (lambda (a b) (if (string-equal a b) | |
| 90 (setq count (1+ count))))) | |
| 91 (function (lambda (a b) (string-equal a b)))))) | |
| 92 (while (setq elt1 (car lst) elt2 (car (cdr lst))) | |
| 93 (if (funcall test elt1 elt2) | |
| 94 (setcdr lst (cdr (cdr lst))) | |
| 95 (setq lst (cdr lst))))) | |
| 96 (if count (cons count sorted-strings) sorted-strings)) | |
| 97 | |
| 98 (defun br-member-sorted-strings (elt list) | |
| 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. | |
| 101 The value returned is actually the tail of LIST whose car is ELT." | |
| 102 (while (and list (not (string-equal (car list) elt))) | |
| 103 (setq list (and (string-lessp (car list) elt) | |
| 104 (cdr list)))) | |
| 105 list) | |
| 106 | |
| 107 (defun br-pathname-head (path) | |
| 108 (if (string-match "\\(.+\\)\\." path) | |
| 109 (substring path 0 (match-end 1)) | |
| 110 path)) | |
| 111 | |
| 112 (defun br-quote-match (match-num) | |
| 113 "Quote special symbols in last matched expression MATCH-NUM." | |
| 114 (br-regexp-quote (buffer-substring (match-beginning match-num) | |
| 115 (match-end match-num)))) | |
| 116 | |
| 117 (defun br-rassoc (elt 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 | |
| 120 starting at the element whose cdr is ELT." | |
| 121 (while (and list (not (equal (cdr (car list)) elt))) | |
| 122 (setq list (cdr list))) | |
| 123 list) | |
| 124 | |
| 125 (defun br-regexp-quote (obj) | |
| 126 "If OBJ is a string, quote and return it for use in a regular expression." | |
| 127 ;; Don't use (stringp obj) here since we want to signal an error if some | |
| 128 ;; caller ever passes in a non-nil, non-string object, to aid in debugging. | |
| 129 (if obj (regexp-quote obj))) | |
| 130 | |
| 131 (defun br-relative-path (filename &optional directory) | |
| 132 "Convert FILENAME to be relative to DIRECTORY or default-directory. | |
| 133 The shorter of the absolute and relative paths is returned." | |
| 134 (let ((relative-path (file-relative-name filename directory))) | |
| 135 (if (< (length relative-path) (length filename)) | |
| 136 relative-path | |
| 137 filename))) | |
| 138 | |
| 139 (defmacro br-set-cons (set elt) | |
| 140 "Add to SET element ELT. Returns nil iff ELT is already in SET. | |
| 141 Uses 'equal' for comparison." | |
| 142 (` (if (br-member (, elt) (, set)) | |
| 143 nil | |
| 144 (setq (, set) (cons (, elt) (, set)))))) | |
| 145 | |
| 146 | |
| 147 (defun br-wind-line-at-point () | |
| 148 "Return window relative line number that point is on." | |
| 149 (max 0 (1- (- (count-lines 1 (1+ (point))) | |
| 150 (count-lines 1 (window-start)))))) | |
| 151 | |
| 152 ;;; ************************************************************************ | |
| 153 ;;; Browser public functions | |
| 154 ;;; ************************************************************************ | |
| 155 | |
| 156 (defun br-add-class (class-name &optional class-path lib-table-p save-file) | |
| 157 "Add or replace CLASS-NAME in current Environment. | |
| 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 | |
| 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 | |
| 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. | |
| 164 Does not update children lookup table." | |
| 165 (interactive | |
| 166 (list (read-string "Class name to add: ") | |
| 167 (read-file-name (concat "Class file name" | |
| 168 (if buffer-file-name | |
| 169 " (default <current file>)") | |
| 170 ": ") | |
| 171 nil buffer-file-name t) | |
| 172 (y-or-n-p "Add to Library, rather than System tables? ") | |
| 173 (y-or-n-p | |
| 174 (concat "Save tables after addition to " br-env-file "? ")))) | |
| 175 ;; | |
| 176 ;; Pseudo code: | |
| 177 ;; | |
| 178 ;; If class-name is in table | |
| 179 ;; If function called interactively | |
| 180 ;; Query whether should overwrite class-name in tables | |
| 181 ;; If yes | |
| 182 ;; Replace entry | |
| 183 ;; else | |
| 184 ;; Don't add class; do nothing | |
| 185 ;; end | |
| 186 ;; else | |
| 187 ;; Store class in all necessary tables | |
| 188 ;; end | |
| 189 ;; else | |
| 190 ;; Store class under key in all necessary tables | |
| 191 ;; end | |
| 192 ;; | |
| 193 (or class-path (setq class-path buffer-file-name) | |
| 194 (error "No class pathname specified.")) | |
| 195 (if (or (string-equal class-name "") | |
| 196 (not (or (equal class-path br-null-path) | |
| 197 (file-exists-p class-path)))) | |
| 198 (error (format "Invalid class specified, '%s', in: %s" class-name class-path))) | |
| 199 ;; Is class already in Environment? | |
| 200 (if (hash-key-p class-name (br-get-htable | |
| 201 (if lib-table-p "lib-parents" "sys-parents"))) | |
| 202 (if (interactive-p) | |
| 203 (if (y-or-n-p (format "Overwrite existing '%s' entry? " class-name)) | |
| 204 (br-real-add-class lib-table-p class-name class-path 'replace) | |
| 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)) | |
| 208 (cond ((eq save-file nil)) | |
| 209 ((eq save-file t) (br-env-save)) | |
| 210 ((br-env-save save-file)))) | |
| 211 | |
| 212 (defun br-build-lib-htable () | |
| 213 "Build Library dependent Environment." | |
| 214 (interactive) | |
| 215 (cond ((and (interactive-p) | |
| 216 (not (y-or-n-p "Rebuild Library Environment? "))) | |
| 217 nil) | |
| 218 (t | |
| 219 (message "Building Library Environment...") | |
| 220 (sit-for 2) | |
| 221 (br-real-build-alists br-lib-search-dirs) | |
| 222 (setq br-lib-paths-htable (hash-make br-paths-alist) | |
| 223 br-lib-parents-htable (hash-make br-parents-alist)) | |
| 224 (run-hooks 'br-after-build-lib-hook) | |
| 225 (br-env-set-htables) | |
| 226 (br-build-children-htable) | |
| 227 ;; Set prev-search-dirs so table rebuilds are not triggered. | |
| 228 (setq br-lib-prev-search-dirs br-lib-search-dirs) | |
| 229 (if (interactive-p) (br-env-save)) | |
| 230 (message "Building Library Environment...Done") | |
| 231 t))) | |
| 232 | |
| 233 (defun br-build-sys-htable () | |
| 234 "Build System dependent class Environment." | |
| 235 (interactive) | |
| 236 (cond ((and (interactive-p) | |
| 237 (not (y-or-n-p "Rebuild System Environment? "))) | |
| 238 nil) | |
| 239 (t | |
| 240 (message "Building System Environment...") | |
| 241 (sit-for 2) | |
| 242 (br-real-build-alists br-sys-search-dirs) | |
| 243 (setq br-sys-paths-htable (hash-make br-paths-alist) | |
| 244 br-sys-parents-htable (hash-make br-parents-alist)) | |
| 245 (run-hooks 'br-after-build-sys-hook) | |
| 246 (br-env-set-htables) | |
| 247 (br-build-children-htable) | |
| 248 ;; Set prev-search-dirs so table rebuilds are not triggered. | |
| 249 (setq br-sys-prev-search-dirs br-sys-search-dirs) | |
| 250 (if (interactive-p) (br-env-save)) | |
| 251 (message "Building System Environment...Done") | |
| 252 t))) | |
| 253 | |
| 254 (defun br-class-in-table-p (class-name) | |
| 255 "Return t iff CLASS-NAME is found in current Environment." | |
| 256 (interactive (list (br-complete-class-name))) | |
| 257 (if class-name (hash-key-p class-name (br-get-parents-htable)))) | |
| 258 | |
| 259 (defun br-class-path (class-name &optional insert) | |
| 260 "Return full path, if any, to CLASS-NAME. | |
| 261 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 | |
| 263 unique. Set 'br-lib/sys-search-dirs' properly before use." | |
| 264 (interactive (list (br-complete-class-name))) | |
| 265 (setq class-name (if class-name (br-set-case class-name))) | |
| 266 (let* ((class-path) | |
| 267 (class-htable (br-get-paths-htable))) | |
| 268 (hash-map | |
| 269 (function (lambda (val-key-cons) | |
| 270 (and (null class-path) | |
| 271 (br-member-sorted-strings class-name (car val-key-cons)) | |
| 272 (setq class-path (br-select-path val-key-cons nil))))) | |
| 273 class-htable) | |
| 274 (if (equal class-path br-null-path) | |
| 275 (setq class-path nil)) | |
| 276 (and (interactive-p) (setq insert current-prefix-arg)) | |
| 277 (if (and insert class-path) | |
| 278 (insert class-path) | |
| 279 (if (interactive-p) | |
| 280 (message | |
| 281 (or class-path | |
| 282 (format | |
| 283 "(OO-Browser): No '%s' class found in 'br-lib/sys-search-dirs'." | |
| 284 class-name))))) | |
| 285 class-path)) | |
| 286 | |
| 287 (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. | |
| 289 Return t if class is successfully displayed, nil otherwise. Can also | |
| 290 signal an error when called interactively." | |
| 291 (interactive) | |
| 292 (and (interactive-p) (setq view-only current-prefix-arg)) | |
| 293 (let ((class-path) | |
| 294 (info (equal br-lang-prefix "info-")) | |
| 295 (err)) | |
| 296 (setq class-name | |
| 297 (or class-name (br-complete-class-name)) | |
| 298 class-path (br-class-path class-name)) | |
| 299 (cond | |
| 300 (info (info-find-nd class-path class-name (not view-only))) | |
| 301 (class-path | |
| 302 (if (file-readable-p class-path) | |
| 303 (progn (if view-only | |
| 304 (funcall br-view-file-function class-path other-win) | |
| 305 (funcall br-edit-file-function class-path other-win) | |
| 306 ;; Handle case of already existing buffer in | |
| 307 ;; read only mode. | |
| 308 (and buffer-read-only | |
| 309 (file-writable-p class-path) | |
| 310 (progn (setq buffer-read-only nil) | |
| 311 ;; Force mode-line redisplay | |
| 312 (set-buffer-modified-p | |
| 313 (buffer-modified-p))))) | |
| 314 (br-major-mode) | |
| 315 (let ((opoint (point)) | |
| 316 (start) | |
| 317 (pmin (point-min)) | |
| 318 (pmax (point-max)) | |
| 319 (class-def (br-class-definition-regexp class-name))) | |
| 320 (widen) | |
| 321 (goto-char (point-min)) | |
| 322 (if br-narrow-view-to-class | |
| 323 ;; Display file narrowed to definition of | |
| 324 ;; 'class-name'. | |
| 325 (if (re-search-forward class-def nil t) | |
| 326 ;; Narrow display to this class | |
| 327 (progn (narrow-to-region | |
| 328 (progn (setq opoint | |
| 329 (goto-char | |
| 330 (match-beginning 0))) | |
| 331 (br-to-comments-begin) | |
| 332 (setq start (point)) | |
| 333 (goto-char opoint) | |
| 334 start) | |
| 335 (progn (br-to-class-end) | |
| 336 (point))) | |
| 337 (goto-char (point-min))) | |
| 338 (goto-char opoint) | |
| 339 (narrow-to-region pmin pmax) | |
| 340 (setq err (format "(OO-Browser): No '%s' in %s" class-name | |
| 341 class-path)) | |
| 342 ) | |
| 343 (if (re-search-forward class-def nil t) | |
| 344 (progn (setq opoint (goto-char (match-beginning 0))) | |
| 345 (br-to-comments-begin) | |
| 346 (recenter 0)) | |
| 347 (goto-char opoint) | |
| 348 (narrow-to-region pmin pmax) | |
| 349 (setq err (format "(OO-Browser): No '%s' in %s" class-name | |
| 350 class-path)) | |
| 351 ))) | |
| 352 (setq class-path t)) | |
| 353 (setq err (format "(OO-Browser): '%s' - src file not found or not readable, %s" | |
| 354 class-name class-path) | |
| 355 class-path nil) | |
| 356 ) | |
| 357 (if (interactive-p) | |
| 358 (setq err | |
| 359 (format "(OO-Browser): No '%s' class defined in Environment." | |
| 360 class-name)) | |
| 361 ))) | |
| 362 (if err (error err)) | |
| 363 class-path)) | |
| 364 | |
| 365 (defun br-major-mode () | |
| 366 "Invoke language-specific major mode on current buffer if not already set." | |
| 367 (or (eq major-mode (symbol-function 'br-lang-mode)) | |
| 368 (br-lang-mode))) | |
| 369 | |
| 370 (defun br-show-children (class-name) | |
| 371 "Return children of CLASS-NAME from current Environment." | |
| 372 (interactive (list (br-complete-class-name t))) | |
| 373 (and class-name | |
| 374 (br-get-children class-name))) | |
| 375 | |
| 376 (defun br-show-parents (class-name) | |
| 377 "Return parents of CLASS-NAME from Environment or scan of current buffer's source." | |
| 378 (interactive (list (br-complete-class-name t))) | |
| 379 (if class-name | |
| 380 (if (br-class-in-table-p class-name) | |
| 381 (br-get-parents class-name) | |
| 382 (if (and buffer-file-name (file-readable-p buffer-file-name)) | |
| 383 (let ((br-view-file-function 'br-insert-file-contents)) | |
| 384 (br-get-parents-from-source buffer-file-name class-name)))))) | |
| 385 | |
| 386 (defun br-undefined-classes () | |
| 387 "Return a list of the classes referenced but not defined within the current Environment." | |
| 388 (let ((classes (hash-get br-null-path (br-get-paths-htable)))) | |
| 389 (delq nil (mapcar (function (lambda (class) | |
| 390 ;; Remove default classes | |
| 391 (if (/= (aref class 0) ?\[) | |
| 392 class))) | |
| 393 classes)))) | |
| 394 | |
| 395 ;;; ************************************************************************ | |
| 396 ;;; Private functions | |
| 397 ;;; ************************************************************************ | |
| 398 | |
| 399 (defun br-add-to-paths-htable (class-name paths-key htable) | |
| 400 "Add CLASS-NAME under PATHS-KEY in paths lookup HTABLE, keeping the classes sorted." | |
| 401 (let ((other-classes (hash-get paths-key htable))) | |
| 402 (if (and other-classes (br-member-sorted-strings class-name other-classes)) | |
| 403 nil | |
| 404 (hash-add (sort (cons class-name other-classes) 'string-lessp) | |
| 405 paths-key htable)))) | |
| 406 | |
| 407 (defun br-build-lib-parents-htable () | |
| 408 (interactive) | |
| 409 (if (not br-lib-search-dirs) | |
| 410 nil | |
| 411 (message "Building Library parent...") | |
| 412 (sit-for 2) | |
| 413 (setq br-lib-parents-htable | |
| 414 (hash-make | |
| 415 (if br-lib-paths-htable | |
| 416 (br-real-build-parents-alist br-lib-paths-htable) | |
| 417 (br-real-build-alists br-lib-search-dirs) | |
| 418 br-parents-alist))) | |
| 419 (if (interactive-p) (br-env-save)) | |
| 420 (message "Building Library parent...Done"))) | |
| 421 | |
| 422 (defun br-build-lib-paths-htable () | |
| 423 (interactive) | |
| 424 (if (not br-lib-search-dirs) | |
| 425 nil | |
| 426 (message "Building Library paths...") | |
| 427 (sit-for 2) | |
| 428 (br-real-build-alists br-lib-search-dirs) | |
| 429 (setq br-lib-paths-htable (hash-make br-paths-alist)) | |
| 430 (if (interactive-p) (br-env-save)) | |
| 431 (message "Building Library paths...Done"))) | |
| 432 | |
| 433 (defun br-build-sys-parents-htable () | |
| 434 (interactive) | |
| 435 (if (not br-sys-search-dirs) | |
| 436 nil | |
| 437 (message "Building System parents...") | |
| 438 (sit-for 2) | |
| 439 (setq br-sys-parents-htable | |
| 440 (hash-make | |
| 441 (if br-sys-paths-htable | |
| 442 (br-real-build-parents-alist br-sys-paths-htable) | |
| 443 (br-real-build-alists br-sys-search-dirs) | |
| 444 br-parents-alist))) | |
| 445 (if (interactive-p) (br-env-save)) | |
| 446 (message "Building System parents...Done"))) | |
| 447 | |
| 448 (defun br-build-sys-paths-htable () | |
| 449 (interactive) | |
| 450 (if (not br-sys-search-dirs) | |
| 451 nil | |
| 452 (message "Building System paths...") | |
| 453 (sit-for 2) | |
| 454 (br-real-build-alists br-sys-search-dirs) | |
| 455 (setq br-sys-paths-htable (hash-make br-paths-alist)) | |
| 456 (if (interactive-p) (br-env-save)) | |
| 457 (message "Building System paths...Done"))) | |
| 458 | |
| 459 (defun br-build-children-htable () | |
| 460 (interactive) | |
| 461 (setq br-children-htable (br-real-build-children-htable)) | |
| 462 (if (interactive-p) (br-env-save))) | |
| 463 | |
| 464 (defun br-build-parents-htable () | |
| 465 (interactive) | |
| 466 (br-build-sys-parents-htable) | |
| 467 (br-build-lib-parents-htable) | |
| 468 ;; Make System entries override Library entries which they duplicate, since | |
| 469 ;; this is generally more desireable than merging the two. | |
| 470 (let ((hash-merge-values-function (function (lambda (val1 val2) val1)))) | |
| 471 (setq br-parents-htable (hash-merge br-sys-parents-htable | |
| 472 br-lib-parents-htable))) | |
| 473 (if (interactive-p) (br-env-save))) | |
| 474 | |
| 475 (defun br-build-paths-htable () | |
| 476 (interactive) | |
| 477 (br-build-sys-paths-htable) | |
| 478 (br-build-lib-paths-htable) | |
| 479 (setq br-paths-htable (hash-merge br-sys-paths-htable br-lib-paths-htable)) | |
| 480 (if (interactive-p) (br-env-save))) | |
| 481 | |
| 482 (defun br-class-defined-p (class) | |
| 483 "Return path for CLASS if defined in current Environment. | |
| 484 Otherwise, display error and return nil." | |
| 485 (or (br-class-path class) | |
| 486 (progn | |
| 487 (beep) | |
| 488 (message | |
| 489 (if (br-class-in-table-p class) | |
| 490 (format "(OO-Browser): Class '%s' referenced but not defined in Environment." | |
| 491 class) | |
| 492 (format "(OO-Browser): Class '%s' not defined in Environment." | |
| 493 class))) | |
| 494 nil))) | |
| 495 | |
| 496 (defun br-check-for-class (cl &optional other-win) | |
| 497 "Try to display class CL. | |
| 498 Display message and return nil if unsucessful." | |
| 499 (if (br-class-in-table-p cl) | |
| 500 (or (br-find-class cl nil other-win) | |
| 501 (progn | |
| 502 (beep) | |
| 503 (message | |
| 504 (format "(OO-Browser): Class '%s' referenced but not defined in Environment." | |
| 505 cl)) | |
| 506 t)))) | |
| 507 | |
| 508 (defun br-get-children (class-name) | |
| 509 "Return list of children of CLASS-NAME from child lookup table. | |
| 510 Those which directly inherit from CLASS-NAME." | |
| 511 (setq class-name (and class-name (br-set-case class-name))) | |
| 512 (br-set-of-strings (hash-get class-name (br-get-children-htable)))) | |
| 513 | |
| 514 (defun br-get-parents (class-name) | |
| 515 "Return list of parents of CLASS-NAME from parent lookup table. | |
| 516 Those from which CLASS-NAME directly inherits." | |
| 517 (setq class-name (and class-name (br-set-case class-name))) | |
| 518 (br-set-of-strings (hash-get class-name (br-get-parents-htable)))) | |
| 519 | |
| 520 (defun br-get-children-htable () | |
| 521 "Loads or builds 'br-children-htable' if necessary and returns value." | |
| 522 (br-get-htable "children")) | |
| 523 | |
| 524 (defun br-get-paths-htable () | |
| 525 "Loads or builds 'br-paths-htable' if necessary and returns value." | |
| 526 (br-get-htable "paths")) | |
| 527 | |
| 528 (defun br-get-parents-htable () | |
| 529 "Loads or builds 'br-parents-htable' if necessary and returns value." | |
| 530 (br-get-htable "parents")) | |
| 531 | |
| 532 (defun br-get-children-from-parents-htable (class-name) | |
| 533 "Return list of children of CLASS-NAME. | |
| 534 Those that directly inherit from CLASS-NAME. Use parent lookup table to | |
| 535 compute children." | |
| 536 (setq class-name (and class-name (br-set-case class-name))) | |
| 537 (delq nil (hash-map (function (lambda (cns) | |
| 538 (if (and (consp cns) | |
| 539 (br-member class-name (car cns))) | |
| 540 (cdr cns)))) | |
| 541 (br-get-parents-htable)))) | |
| 542 | |
| 543 (defun br-get-htable (htable-type) | |
| 544 "Return hash table corresponding to string, HTABLE-TYPE. When necessary, | |
| 545 load the hash table from a file or build it." | |
| 546 (let* ((htable-symbol (intern-soft (concat "br-" htable-type "-htable"))) | |
| 547 (htable-specific (if (string-match "sys\\|lib" htable-type) | |
| 548 (substring htable-type (match-beginning 0) | |
| 549 (match-end 0)))) | |
| 550 changed-types non-matched-types) | |
| 551 (if (equal htable-type "children") | |
| 552 nil | |
| 553 (if (and (or (not htable-specific) (equal htable-specific "lib")) | |
| 554 (or (null (symbol-value htable-symbol)) | |
| 555 (not (equal br-lib-prev-search-dirs br-lib-search-dirs)))) | |
| 556 (setq changed-types '("lib"))) | |
| 557 (if (and (or (not htable-specific) (equal htable-specific "sys")) | |
| 558 (or (null (symbol-value htable-symbol)) | |
| 559 (not (equal br-sys-prev-search-dirs br-sys-search-dirs)))) | |
| 560 (setq changed-types (cons "sys" changed-types)))) | |
| 561 (if (and (or br-lib-search-dirs br-sys-search-dirs) | |
| 562 (or changed-types (null (symbol-value htable-symbol))) | |
| 563 (not (boundp 'br-loaded))) | |
| 564 ;; | |
| 565 ;; Then need to load or rebuild htable. | |
| 566 ;; | |
| 567 (progn (if (and br-env-file | |
| 568 (file-exists-p br-env-file)) | |
| 569 ;; | |
| 570 ;; Try to load from file. | |
| 571 ;; | |
| 572 (progn (setq non-matched-types | |
| 573 (br-env-load-matching-htables changed-types)) | |
| 574 (if non-matched-types | |
| 575 (setq changed-types | |
| 576 (delq nil (mapcar | |
| 577 (function | |
| 578 (lambda (type) | |
| 579 (if (br-member type | |
| 580 changed-types) | |
| 581 type))) | |
| 582 non-matched-types))) | |
| 583 (and changed-types (br-env-set-htables)) | |
| 584 (setq changed-types nil) | |
| 585 (cond (htable-specific) | |
| 586 ((equal htable-type "children") | |
| 587 (progn (goto-char (point-min)) | |
| 588 (setq br-children-htable | |
| 589 (cdr (br-env-file-sym-val | |
| 590 "br-children-htable"))))) | |
| 591 ((let ((suffix | |
| 592 (concat "-" htable-type "-htable")) | |
| 593 (hash-merge-values-function | |
| 594 'hash-merge-values)) | |
| 595 ;; Make System entries override | |
| 596 ;; Library entries which they | |
| 597 ;; duplicate, if this is the parents | |
| 598 ;; htable. | |
| 599 (if (equal htable-type "parents") | |
| 600 (setq hash-merge-values-function | |
| 601 (function | |
| 602 (lambda (val1 val2) val1)))) | |
| 603 (set htable-symbol | |
| 604 (hash-merge | |
| 605 (symbol-value | |
| 606 (intern-soft | |
| 607 (concat "br-sys" suffix))) | |
| 608 (symbol-value | |
| 609 (intern-soft | |
| 610 (concat | |
| 611 "br-lib" suffix))) | |
| 612 )))))))) | |
| 613 ;; Rebuild any lists that need to be changed. | |
| 614 (mapcar | |
| 615 (function | |
| 616 (lambda (type-str) | |
| 617 (let ((suffix (concat "-" htable-type "-htable"))) | |
| 618 (funcall (intern-soft | |
| 619 (concat "br-build-" type-str suffix))) | |
| 620 (and htable-specific | |
| 621 ;; Make System entries override Library entries | |
| 622 ;; which they duplicate, if this is the parents | |
| 623 ;; htable. | |
| 624 (let ((hash-merge-values-function | |
| 625 'hash-merge-values)) | |
| 626 (if (equal htable-type "parents") | |
| 627 (setq hash-merge-values-function | |
| 628 (function (lambda (val1 val2) val1)))) | |
| 629 (set htable-symbol | |
| 630 (hash-merge (symbol-value | |
| 631 (intern-soft | |
| 632 (concat "br-sys" suffix))) | |
| 633 (symbol-value | |
| 634 (intern-soft | |
| 635 (concat "br-lib" suffix))) | |
| 636 ))))))) | |
| 637 changed-types) | |
| 638 (if (and changed-types br-env-file) | |
| 639 (br-env-save)) | |
| 640 (let ((buf (get-file-buffer br-env-file))) | |
| 641 (and buf (kill-buffer buf))) | |
| 642 )) | |
| 643 ;; Return non-nil hash table. | |
| 644 (if (null (symbol-value htable-symbol)) | |
| 645 (set htable-symbol (hash-make 0)) | |
| 646 (symbol-value htable-symbol)))) | |
| 647 | |
| 648 (defun br-get-top-class-list (htable-type-str) | |
| 649 "Returns unordered list of top-level classes. | |
| 650 Those that do not explicitly inherit from any other classes. Obtains classes | |
| 651 from list denoted by HTABLE-TYPE-STR whose values may be: | |
| 652 \"parents\", \"sys-parents\", or \"lib-parents\"." | |
| 653 (delq nil (hash-map (function | |
| 654 (lambda (cns) | |
| 655 (and (null (car cns)) (cdr cns)))) | |
| 656 (br-get-htable htable-type-str)))) | |
| 657 | |
| 658 (defun br-get-top-classes () | |
| 659 "Returns lexicographically ordered list of top-level classes. | |
| 660 Those that do not explicitly inherit from any other classes." | |
| 661 (br-get-top-class-list "parents")) | |
| 662 | |
| 663 (defun br-get-lib-top-classes () | |
| 664 "Returns lexicographically ordered list of top-level Library classes. | |
| 665 Those that do not explicitly inherit from any other classes." | |
| 666 (br-get-top-class-list "lib-parents")) | |
| 667 | |
| 668 (defun br-get-sys-top-classes () | |
| 669 "Returns lexicographically ordered list of top-level System classes. | |
| 670 Those that do not explicitly inherit from any other classes." | |
| 671 (br-get-top-class-list "sys-parents")) | |
| 672 | |
| 673 (defun br-has-children-p (class-name) | |
| 674 "Return non-nil iff CLASS-NAME has at least one child. | |
| 675 That is a class that directly inherits from CLASS-NAME." | |
| 676 (setq class-name (and class-name (br-set-case class-name))) | |
| 677 (hash-get class-name (br-get-children-htable))) | |
| 678 | |
| 679 (defun br-has-parents-p (class-name) | |
| 680 "Return non-nil iff CLASS-NAME has at least one parent. | |
| 681 That is a class which is a direct ancestor of CLASS-NAME." | |
| 682 (setq class-name (and class-name (br-set-case class-name))) | |
| 683 (hash-get class-name (br-get-parents-htable))) | |
| 684 | |
| 685 (defun br-get-process-group (group max) | |
| 686 "Return list of all active processes in GROUP (a string). | |
| 687 MAX is max number of processes to check for." | |
| 688 (let ((i 0) | |
| 689 (proc-list)) | |
| 690 (while (<= i max) | |
| 691 (setq i (1+ i) | |
| 692 proc-list (cons (get-process (concat group (int-to-string i))) | |
| 693 proc-list))) | |
| 694 (delq nil proc-list))) | |
| 695 | |
| 696 | |
| 697 (defun br-kill-process-group (group max group-descrip) | |
| 698 "Optionally question user, then kill all subprocesses in named GROUP. | |
| 699 Processes are numbered one to MAX, some of which may have been killed already. | |
| 700 User is prompted with a string containing GROUP-DESCRIP, only if non-nil. | |
| 701 Return list of processes killed." | |
| 702 (let ((proc-list (br-get-process-group group max))) | |
| 703 (if proc-list | |
| 704 (if (or (null group-descrip) | |
| 705 (y-or-n-p (concat "Terminate all " group-descrip "? "))) | |
| 706 (prog1 (mapcar 'delete-process proc-list) | |
| 707 (message "")))))) | |
| 708 | |
| 709 (defun br-real-add-class (lib-table-p class-name class-path &optional replace) | |
| 710 "Add or replace class in current Environment. | |
| 711 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 | |
| 713 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 | |
| 715 update children lookup table." | |
| 716 (or class-path (setq class-path buffer-file-name)) | |
| 717 (let ((par-list) | |
| 718 (paths-key class-path) | |
| 719 (func) | |
| 720 (class class-name)) | |
| 721 (if replace | |
| 722 (setq func 'hash-replace | |
| 723 class-name (br-first-match | |
| 724 (concat "^" (regexp-quote class-name) "$") | |
| 725 (hash-get paths-key | |
| 726 (if lib-table-p | |
| 727 (br-get-htable "lib-paths") | |
| 728 (br-get-htable "sys-paths")))) | |
| 729 par-list | |
| 730 (and (stringp class-path) (file-readable-p class-path) | |
| 731 (let ((br-view-file-function 'br-insert-file-contents)) | |
| 732 (br-get-parents-from-source class-path class-name)))) | |
| 733 (setq func 'hash-add)) | |
| 734 ;; Signal error if class-name is invalid. | |
| 735 (if (null class-name) | |
| 736 (if replace | |
| 737 (error "(br-real-add-class): '%s' not found in %s classes, so cannot replace it." | |
| 738 class (if lib-table-p "Library" "System")) | |
| 739 (error | |
| 740 "(br-real-add-class): Attempt to add null class to %s classes." | |
| 741 (if lib-table-p "Library" "System")))) | |
| 742 ;; | |
| 743 (mapcar | |
| 744 (function | |
| 745 (lambda (type) | |
| 746 (let ((par-htable (br-get-htable (concat type "parents"))) | |
| 747 (path-htable (br-get-htable (concat type "paths")))) | |
| 748 (funcall func par-list class-name par-htable) | |
| 749 (br-add-to-paths-htable class-name paths-key path-htable)))) | |
| 750 (list (if lib-table-p "lib-" "sys-") "")))) | |
| 751 | |
| 752 (defun br-real-delete-class (class-name) | |
| 753 "Delete class CLASS-NAME from current Environment. | |
| 754 No error occurs if the class is undefined in the Environment." | |
| 755 (require 'set) | |
| 756 (let ((paths-key (br-class-path class-name)) | |
| 757 htable) | |
| 758 (setq class-name | |
| 759 (br-first-match (concat "^" class-name "$") | |
| 760 (hash-get paths-key (br-get-paths-htable)))) | |
| 761 (if class-name | |
| 762 (progn (mapcar | |
| 763 (function | |
| 764 (lambda (type) | |
| 765 (hash-delete class-name | |
| 766 (br-get-htable (concat type "parents"))) | |
| 767 (setq htable (br-get-htable (concat type "paths"))) | |
| 768 (if (hash-key-p paths-key htable) | |
| 769 (hash-replace | |
| 770 (set:remove | |
| 771 class-name | |
| 772 (hash-get paths-key htable)) | |
| 773 paths-key htable)))) | |
| 774 '("lib-" "sys-" "")) | |
| 775 (hash-delete class-name (br-get-children-htable)))))) | |
| 776 | |
| 777 (defun br-real-build-children-htable () | |
| 778 "Build and return Environment parent to child lookup table." | |
| 779 (let* ((par-ht (br-get-parents-htable)) | |
| 780 (htable (hash-make (hash-size par-ht))) | |
| 781 (child)) | |
| 782 (hash-map | |
| 783 (function | |
| 784 (lambda (par-child-cns) | |
| 785 (setq child (cdr par-child-cns)) | |
| 786 (mapcar | |
| 787 (function | |
| 788 (lambda (parent) | |
| 789 (hash-add | |
| 790 (cons child (hash-get parent htable)) | |
| 791 parent htable))) | |
| 792 (car par-child-cns)))) | |
| 793 par-ht) | |
| 794 (hash-map (function | |
| 795 (lambda (children-parent-cns) | |
| 796 (hash-replace (sort (car children-parent-cns) 'string-lessp) | |
| 797 (cdr children-parent-cns) htable))) | |
| 798 htable) | |
| 799 htable)) | |
| 800 | |
| 801 (defun br-real-get-children (class-name) | |
| 802 "Return list of child classes of CLASS-NAME listed in Environment parents htable." | |
| 803 (delq nil (hash-map | |
| 804 (function | |
| 805 (lambda (cns) | |
| 806 (if (and (consp cns) | |
| 807 (br-member class-name (car cns))) | |
| 808 (cdr cns)))) | |
| 809 (br-get-parents-htable)))) | |
| 810 | |
| 811 (defun br-real-build-alists (search-dirs) | |
| 812 "Use SEARCH-DIRS to build 'br-paths-alist' and 'br-parents-alist'." | |
| 813 (setq br-paths-alist nil br-parents-alist nil) | |
| 814 (br-feature-tags-init) | |
| 815 (br-real-build-al search-dirs) | |
| 816 (setq br-paths-alist br-paths-alist) | |
| 817 (br-feature-tags-save) | |
| 818 br-paths-alist) | |
| 819 | |
| 820 (defvar br-paths-alist nil) | |
| 821 (defvar br-parents-alist nil) | |
| 822 | |
| 823 (defun br-skip-dir-p (dir-name) | |
| 824 "Returns non-nil iff DIR-NAME is matched by a member of 'br-skip-dir-regexps'." | |
| 825 (delq nil | |
| 826 (mapcar (function | |
| 827 (lambda (dir-regexp) | |
| 828 (string-match dir-regexp | |
| 829 (file-name-nondirectory | |
| 830 (directory-file-name dir-name))))) | |
| 831 br-skip-dir-regexps))) | |
| 832 | |
| 833 ;;; If abbreviate-file-name is not defined, just make it return the same | |
| 834 ;;; string. | |
| 835 (or (fboundp 'abbreviate-file-name) | |
| 836 (fset 'abbreviate-file-name 'identity)) | |
| 837 | |
| 838 (defun br-real-build-al (search-dirs) | |
| 839 "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." | |
| 841 (let ((inhibit-local-variables nil) | |
| 842 (enable-local-variables t) | |
| 843 (files) | |
| 844 ;; These are used in the 'br-search-directory' function. | |
| 845 classes parents paths-parents-cons) | |
| 846 (mapcar | |
| 847 (function | |
| 848 (lambda (dir) | |
| 849 (if (or (null dir) (equal dir "") | |
| 850 (progn (setq dir (file-name-as-directory dir)) | |
| 851 (br-skip-dir-p dir))) | |
| 852 nil | |
| 853 (setq files (if (and (file-directory-p dir) | |
| 854 (file-readable-p dir)) | |
| 855 (directory-files dir t br-file-dir-regexp))) | |
| 856 ;; Extract all class/parent names in all source files in a | |
| 857 ;; particular directory. | |
| 858 (if files | |
| 859 (progn (message "Scanning %s in %s ..." | |
| 860 (file-name-nondirectory | |
| 861 (directory-file-name dir)) | |
| 862 (abbreviate-file-name | |
| 863 (or (file-name-directory | |
| 864 (directory-file-name dir)) | |
| 865 ""))) | |
| 866 (br-search-directory dir files) | |
| 867 ;; Call same function on all the directories below | |
| 868 ;; this one. | |
| 869 (br-real-build-al | |
| 870 (mapcar (function (lambda (f) | |
| 871 (if (file-directory-p f) f))) | |
| 872 files))))))) | |
| 873 search-dirs))) | |
| 874 | |
| 875 (defun br-search-directory (dir files) | |
| 876 (mapcar | |
| 877 (function | |
| 878 (lambda (f) | |
| 879 (if (file-readable-p f) | |
| 880 (setq paths-parents-cons | |
| 881 (let ((br-view-file-function 'br-insert-file-contents)) | |
| 882 (message "Scanning %s in %s ..." | |
| 883 (file-name-nondirectory f) | |
| 884 (abbreviate-file-name | |
| 885 (or (file-name-directory f) default-directory))) | |
| 886 (br-get-classes-from-source f nil t)) | |
| 887 classes (car paths-parents-cons) | |
| 888 parents (cdr paths-parents-cons) | |
| 889 br-paths-alist (if classes | |
| 890 (cons (cons (sort classes | |
| 891 'string-lessp) f) | |
| 892 br-paths-alist) | |
| 893 br-paths-alist) | |
| 894 br-parents-alist (if parents | |
| 895 (append br-parents-alist | |
| 896 parents) | |
| 897 br-parents-alist)) | |
| 898 (message "(OO-Browser): Unreadable file: %s in %s" | |
| 899 (file-name-nondirectory f) | |
| 900 (abbreviate-file-name | |
| 901 (or (file-name-directory f) default-directory))) | |
| 902 (sit-for 1)))) | |
| 903 ;; List of files potentially containing classes. | |
| 904 (delq nil | |
| 905 (mapcar | |
| 906 (function | |
| 907 (lambda (f) | |
| 908 (and (string-match br-src-file-regexp f) | |
| 909 (not (file-directory-p f)) | |
| 910 f))) | |
| 911 files)))) | |
| 912 | |
| 913 (defun br-real-build-parents-alist (paths-htable) | |
| 914 "Build and return 'br-parents-alist' of (parent-list . class) elements built from PATHS-HTABLE. | |
| 915 Initializes 'br-parents-alist' to nil." | |
| 916 (let ((inhibit-local-variables nil) | |
| 917 (enable-local-variables t) | |
| 918 (br-view-file-function 'br-insert-file-contents)) | |
| 919 (setq br-parents-alist nil) | |
| 920 (mapcar | |
| 921 (function | |
| 922 (lambda (cl-dir-list) | |
| 923 (mapcar (function | |
| 924 (lambda (class-dir-cons) | |
| 925 (let ((dir (cdr class-dir-cons))) | |
| 926 (mapcar | |
| 927 (function | |
| 928 (lambda (class-name) | |
| 929 (setq br-parents-alist | |
| 930 (cons (cons | |
| 931 (and (stringp dir) | |
| 932 (file-exists-p dir) | |
| 933 (br-get-parents-from-source | |
| 934 dir class-name)) | |
| 935 class-name) | |
| 936 br-parents-alist)))) | |
| 937 (car class-dir-cons))))) | |
| 938 cl-dir-list))) | |
| 939 paths-htable) | |
| 940 br-parents-alist)) | |
| 941 | |
| 942 (defun br-set-lang-env (func sym-list val) | |
| 943 "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 | |
| 945 element with the same name, otherwise set to symbol." | |
| 946 (let ((br) (lang)) | |
| 947 (mapcar (function | |
| 948 (lambda (nm) | |
| 949 (setq br (intern (concat "br-" nm)) | |
| 950 lang (intern-soft (concat br-lang-prefix nm))) | |
| 951 (funcall func br (if val | |
| 952 (symbol-value lang) | |
| 953 (or lang 'br-undefined-function))))) | |
| 954 sym-list))) | |
| 955 | |
| 956 (defun br-undefined-function (&rest ignore) | |
| 957 (interactive) | |
| 958 (error "(OO-Browser): That command is not supported for this language.")) | |
| 959 | |
| 960 (defun br-setup-functions () | |
| 961 "Initialize appropriate function pointers for the current browser language." | |
| 962 (br-set-lang-env 'fset | |
| 963 '("class-definition-regexp" "class-list-filter" | |
| 964 "get-classes-from-source" "get-parents-from-source" | |
| 965 "insert-class-info" "set-case" "set-case-type" | |
| 966 "to-class-end" "to-comments-begin" "to-definition" | |
| 967 "select-path" | |
| 968 | |
| 969 "feature-implementors" "feature-locate-p" | |
| 970 "feature-name-to-regexp" "feature-signature-to-name" | |
| 971 "feature-signature-to-regexp" "feature-tag-class" | |
| 972 "feature-tree-command-p" | |
| 973 "list-categories" "list-features" "list-protocols" | |
| 974 "view-friend" "view-protocol") | |
| 975 nil)) | |
| 976 | |
| 977 (defun br-setup-constants () | |
| 978 "Initialize appropriate constant values for the current browser language." | |
| 979 ;; Clear language-dependent hooks. | |
| 980 (setq br-after-build-lib-hook nil | |
| 981 br-after-build-sys-hook nil) | |
| 982 ;; Set language-specific constants. | |
| 983 (br-set-lang-env 'set '("class-def-regexp" "env-file" | |
| 984 "identifier" "identifier-chars" | |
| 985 "src-file-regexp" "narrow-view-to-class" | |
| 986 "type-tag-separator") | |
| 987 t)) | |
| 988 | |
| 989 ;;; ************************************************************************ | |
| 990 ;;; Private variables | |
| 991 ;;; ************************************************************************ | |
| 992 | |
| 993 (defvar br-lib-search-dirs nil | |
| 994 "List of directories below which library dirs and source files are found. | |
| 995 A library is a stable group of classes. Value is language-specific.") | |
| 996 (defvar br-sys-search-dirs nil | |
| 997 "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 | |
| 999 language-specific.") | |
| 1000 | |
| 1001 (defvar br-lib-prev-search-dirs nil | |
| 1002 "Used to check if 'br-lib-paths-htable' must be regenerated. | |
| 1003 Value is language-specific.") | |
| 1004 (defvar br-sys-prev-search-dirs nil | |
| 1005 "Used to check if 'br-sys-paths-htable' must be regenerated. | |
| 1006 Value is language-specific.") | |
| 1007 | |
| 1008 (defun br-find-file (filename &optional other-win read-only) | |
| 1009 "Edit file FILENAME. | |
| 1010 Switch to a buffer visiting file FILENAME, creating one if none | |
| 1011 already exists. Optional OTHER-WIN means show in other window. | |
| 1012 Optional READ-ONLY means make buffer read-only." | |
| 1013 (interactive "FFind file: ") | |
| 1014 (funcall (if other-win 'switch-to-buffer-other-window 'switch-to-buffer) | |
| 1015 (find-file-noselect filename)) | |
| 1016 (and read-only (setq buffer-read-only t))) | |
| 1017 | |
| 1018 (defun br-find-file-read-only (filename &optional other-win) | |
| 1019 "Display file FILENAME read-only. | |
| 1020 Switch to a buffer visiting file FILENAME, creating one if none | |
| 1021 already exists. Optional OTHER-WIN means show in other window." | |
| 1022 (interactive "FFind file read-only: ") | |
| 1023 (br-find-file filename other-win t)) | |
| 1024 | |
| 1025 (defvar br-edit-file-function 'br-find-file | |
| 1026 "*Function to call to edit a class file within the browser.") | |
| 1027 (defvar br-view-file-function | |
| 1028 (if (eq br-edit-file-function 'br-find-file) | |
| 1029 'br-find-file-read-only | |
| 1030 br-edit-file-function) | |
| 1031 "*Function to call to view a class file within the browser.") | |
| 1032 | |
| 1033 (defvar br-find-file-noselect-function 'find-file-noselect | |
| 1034 "Function to call to load a browser file but not select it. | |
| 1035 The function must return the buffer containing the file's contents.") | |
| 1036 | |
| 1037 (defvar *br-tmp-buffer* "*oobr-tmp*" | |
| 1038 "Name of temporary buffer used by the OO-Browser for parsing source files.") | |
| 1039 | |
| 1040 (defun br-insert-file-contents (filename) | |
| 1041 "Insert FILENAME contents into a temporary buffer and select buffer. | |
| 1042 Does not run any find-file hooks. Marks buffer read-only to prevent | |
| 1043 any accidental editing. | |
| 1044 | |
| 1045 Set 'br-view-file-function' to this function when parsing OO-Browser source | |
| 1046 files for fast loading of many files." | |
| 1047 (let ((buf (get-buffer-create *br-tmp-buffer*))) | |
| 1048 (switch-to-buffer buf) | |
| 1049 (buffer-disable-undo buf) | |
| 1050 (setq buffer-read-only nil) | |
| 1051 (erase-buffer) | |
| 1052 (insert-file-contents filename t))) | |
| 1053 | |
| 1054 (defvar br-lang-prefix nil | |
| 1055 "Prefix string that starts language-specific symbol names.") | |
| 1056 | |
| 1057 (defvar br-children-htable nil | |
| 1058 "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 | |
| 1060 this list. Value is language-specific.") | |
| 1061 (defvar br-parents-htable nil | |
| 1062 "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 | |
| 1064 this list. Value is language-specific.") | |
| 1065 (defvar br-paths-htable nil | |
| 1066 "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. | |
| 1068 'br-build-paths-htable' builds this list. Value is language-specific.") | |
| 1069 | |
| 1070 (defvar br-lib-parents-htable nil | |
| 1071 "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. | |
| 1073 Value is language-specific.") | |
| 1074 (defvar br-lib-paths-htable nil | |
| 1075 "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . DIRECTORY). | |
| 1076 DIRECTORY gives the location of classes found in LIST-OF-CLASS-NAMES. | |
| 1077 Only classes from stable software libraries are used to build the list. | |
| 1078 Value is language-specific.") | |
| 1079 | |
| 1080 (defvar br-sys-parents-htable nil | |
| 1081 "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME). | |
| 1082 Only classes from systems that are likely to change are used to build the | |
| 1083 list. Value is language-specific.") | |
| 1084 (defvar br-sys-paths-htable nil | |
| 1085 "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . DIRECTORY). | |
| 1086 DIRECTORY gives the location of classes found in LIST-OF-CLASS-NAMES. | |
| 1087 Only classes from systems that are likely to change are used to build the | |
| 1088 list. Value is language-specific.") | |
| 1089 | |
| 1090 (defvar br-file-dir-regexp "\\`[^.~#]\\(.*[^.~#]\\)?\\'" | |
| 1091 "Regexp that matches only to files and directories that the OO-Browser should scan. | |
| 1092 Others are ignored.") | |
| 1093 | |
| 1094 (defvar br-src-file-regexp nil | |
| 1095 "Regular expression matching a unique part of source file names and no others.") | |
| 1096 | |
| 1097 (defvar br-narrow-view-to-class nil | |
| 1098 "Non-nil means narrow buffer to just the matching class definition when displayed. | |
| 1099 Don't set this, use the language specific variable instead.") | |
| 1100 | |
| 1101 (provide 'br-lib) |