cgit.sxemacs.org Git - packages/blob - xemacs-packages/oo-browser/br-lib.el

   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:          BeOpen.com
  10 ;;
  11 ;; ORIG-DATE:    22-Mar-90
  12 ;; LAST-MOD:     10-May-01 at 15:17:10 by Bob Weiner
  13
  14 ;;; ************************************************************************
  15 ;;; Inline functions
  16 ;;; ************************************************************************
  17
  18 (defsubst br-get-children-htable ()
  19   "Loads or builds `br-children-htable' if necessary and returns value."
  20   (br-get-htable "children"))
  21
  22 (defsubst br-get-paths-htable ()
  23   "Loads or builds `br-paths-htable' if necessary and returns value."
  24   (br-get-htable "paths"))
  25
  26 (defsubst br-get-parents-htable ()
  27   "Loads or builds `br-parents-htable' if necessary and returns value."
  28   (br-get-htable "parents"))
  29
  30 ;;; ************************************************************************
  31 ;;; Other required Elisp libraries
  32 ;;; ************************************************************************
  33
  34 (require 'br-ftr)
  35 (require 'br-compl)
  36 (require 'set)
  37 (require 'hasht)
  38 (require 'hpath)
  39
  40 ;;; ************************************************************************
  41 ;;; Public variables
  42 ;;; ************************************************************************
  43
  44 (defvar br-null-path "<none>"
  45   "Pathname associated with OO-Browser entities which have no source file.
  46 That is, virtual entities, such as categories.")
  47
  48 (defvar br-empty-htable (hash-make 0)
  49   "An empty hash table used to check whether OO-Browser hash tables are empty.")
  50
  51 ;;; ************************************************************************
  52 ;;; General public functions
  53 ;;; ************************************************************************
  54
  55 (defun br-add-default-classes (class-list)
  56   "Add classes from CLASS-LIST as default classes for the current Environment.
  57 Default class names should be surrounded by square brackets.
  58 Add classes to the list of System classes."
  59   (mapcar (function (lambda (class)
  60                       (br-add-class class br-null-path nil)))
  61           class-list))
  62
  63 (defun br-buffer-replace (regexp to-str &optional literal-flag)
  64   "In current buffer, replace all occurrences of REGEXP with TO-STR.
  65 Optional LITERAL-FLAG non-nil means ignore special regexp characters
  66 and just insert them literally."
  67   (goto-char (point-min))
  68   (while (re-search-forward regexp nil t)
  69     (replace-match to-str t literal-flag)
  70     (backward-char 1)))
  71
  72 (if (fboundp 'buffer-substring-no-properties)
  73 (defalias 'br-buffer-substring 'buffer-substring-no-properties)
  74 (defalias 'br-buffer-substring 'buffer-substring))
  75
  76 (defun br-buffer-delete-c-comments ()
  77   "Remove all // and /* */ comments from the current buffer.
  78 Assumes the buffer is not read-only and does not handled nested
  79 multi-line comments."
  80   (save-excursion
  81     (goto-char (point-min))
  82     (while (re-search-forward "//.*" nil t) (replace-match "" t t))
  83     (goto-char (point-min))
  84     (while (re-search-forward "/\\*" nil t)
  85       (delete-region (match-beginning 0)
  86                      (if (re-search-forward "\\*/" nil t)
  87                          (match-end 0)
  88                        (point-max))))))
  89
  90 (defun br-c-to-comments-begin ()
  91   "Skip back from current point past any preceding C-based comments at the beginning of lines.
  92 Presumes no \"/*\" strings are nested within multi-line comments."
  93   (let ((opoint))
  94     (while (progn (setq opoint (point))
  95                   ;; To previous line
  96                   (if (zerop (forward-line -1))
  97                       (cond
  98                        ;; If begins with "//" or ends with "*/", then is a
  99                        ;; comment.
 100                        ((looking-at "[ \t]*\\(//\\|$\\)"))
 101                        ((looking-at ".*\\*/[ \t]*$")
 102                         (progn (end-of-line)
 103                                ;; Avoid //*** single line comments here.
 104                                (if (re-search-backward "\\(^\\|[^/]\\)/\\*" nil t)
 105                                    (progn (beginning-of-line)
 106                                           (looking-at "[ \t]*/\\*")))))
 107                        (t nil)))))
 108     (goto-char opoint)
 109     ;; Skip past whitespace
 110     (skip-chars-forward " \t\n\r\f")
 111     (beginning-of-line)))
 112
 113 (defun br-delete-space (string)
 114   "Delete any leading and trailing space from STRING and return the STRING."
 115   (if (string-match "\\`[ \t\n\r\f]+" string)
 116       (setq string (substring string (match-end 0))))
 117   (if (string-match "[ \t\n\r\f]+\\'" string)
 118       (setq string (substring string 0 (match-beginning 0))))
 119   string)
 120
 121 (defun br-first-match (regexp list)
 122   "Return non-nil if REGEXP matches to an element of LIST.
 123 All elements of LIST must be strings.
 124 The value returned is the first matched element."
 125   (while (and list (not (string-match regexp (car list))))
 126     (setq list (cdr list)))
 127   (car list))
 128
 129 (defun br-filename-head (path)
 130   (regexp-quote (file-name-sans-extension
 131                  (file-name-nondirectory path))))
 132
 133 (defun br-flatten (obj)
 134   "Return a single-level list of all atoms in OBJ in original order.
 135 OBJ must be a list, cons cell, vector or atom."
 136   ;; Test case:   (br-flatten '((a b (c . d)) e (f (g [h (i j) [k l m]] (n)))))
 137   ;; Should produce: => (a b c d e f g h i j k l m n)
 138   (cond ((null obj) nil)
 139         ((vectorp obj)
 140          ;; convert to list
 141          (setq obj (append obj nil))
 142          ;; flatten new list
 143          (append (br-flatten (car obj)) (br-flatten (cdr obj))))
 144         ((atom obj) (list obj))
 145         ((nlistp obj)
 146          (error "(br-flatten): Invalid type, '%s'" obj))
 147         (t ;; list
 148          (append (br-flatten (car obj)) (br-flatten (cdr obj))))))
 149
 150 (defun br-duplicate-and-unique-strings (sorted-strings)
 151   "Return SORTED-STRINGS list with a list of duplicate entries consed onto the front of the list."
 152   (let ((elt1) (elt2) (lst sorted-strings)
 153         (count 0) (repeat) (duplicates))
 154     (while (setq elt1 (car lst) elt2 (car (cdr lst)))
 155       (cond ((not (string-equal elt1 elt2))
 156              (setq lst (cdr lst)))
 157             ((equal elt1 repeat)
 158             ;; Already recorded this duplicate.
 159              (setcdr lst (cdr (cdr lst))))
 160             (t ;; new duplicate
 161              (setq count (1+ count)
 162                    duplicates (cons elt1 duplicates)
 163                    repeat elt1)
 164              (setcdr lst (cdr (cdr lst))))))
 165     (cons (sort duplicates 'string-lessp) sorted-strings)))
 166
 167 (defun br-set-of-strings (sorted-strings &optional count)
 168   "Return SORTED-STRINGS list with any duplicate entries removed.
 169 Optional COUNT conses number of duplicates on to front of list before return."
 170   (and count (setq count 0))
 171   (let ((elt1) (elt2) (lst sorted-strings)
 172         (test (if count
 173                   (function
 174                     (lambda (a b) (if (string-equal a b)
 175                                       (setq count (1+ count)))))
 176                 (function (lambda (a b) (string-equal a b))))))
 177     (while (setq elt1 (car lst) elt2 (car (cdr lst)))
 178       (if (funcall test elt1 elt2)
 179           (setcdr lst (cdr (cdr lst)))
 180         (setq lst (cdr lst)))))
 181   (if count (cons count sorted-strings) sorted-strings))
 182
 183 (defun br-member-sorted-strings (elt list)
 184   "Return non-nil if ELT is an element of LIST.  Comparison done with `string-equal'.
 185 All ELTs must be strings and the list must be sorted in ascending order.
 186 The value returned is actually the tail of LIST whose car is ELT."
 187   (while (and list (not (string-equal (car list) elt)))
 188     (setq list (and (string-lessp (car list) elt)
 189                     (cdr list))))
 190   list)
 191
 192 (defun br-delete-sorted-strings (elt set)
 193   "Removes element ELT from SET and returns new set.
 194 Assumes SET is a valid set of sorted strings.
 195 Use (setq set (br-delete-sorted-strings elt set)) to assure that the set is
 196 always properly modified."
 197   (let ((rest (br-member-sorted-strings elt set)))
 198     (if rest
 199         (cond ((= (length set) 1) (setq set nil))
 200               ((= (length rest) 1)
 201                (setcdr (nthcdr (- (length set) 2) set) nil))
 202               (t (setcar rest (car (cdr rest)))
 203                  (setcdr rest (cdr (cdr rest)))))))
 204   set)
 205
 206 (defun br-pathname-head (path)
 207   (if (string-match "\\(.+\\)\\." path)
 208       (substring path 0 (match-end 1))
 209     path))
 210
 211 (defun br-quote-match (match-num)
 212   "Quote special symbols in last matched expression MATCH-NUM."
 213   (br-regexp-quote (br-buffer-substring (match-beginning match-num)
 214                                         (match-end match-num))))
 215
 216 (defun br-rassoc (elt list)
 217   "Return non-nil if ELT is the cdr of an element of LIST.
 218 Comparison done with `equal'.  The value is actually the tail of LIST
 219 starting at the element whose cdr is ELT."
 220   (while (and list (not (equal (cdr (car list)) elt)))
 221     (setq list (cdr list)))
 222   list)
 223
 224 (defun br-regexp-quote (obj)
 225   "If OBJ is a string, quote and return it for use in a regular expression."
 226   ;; Don't use (stringp obj) here since we want to signal an error if some
 227   ;; caller ever passes in a non-nil, non-string object, to aid in debugging.
 228   (if obj (regexp-quote obj)))
 229
 230 (defun br-relative-path (filename &optional directory)
 231   "Convert FILENAME to be relative to DIRECTORY or default-directory.
 232 The shorter of the absolute and relative paths is returned."
 233   (let ((relative-path (file-relative-name filename directory)))
 234     (if (< (length relative-path) (length filename))
 235         relative-path
 236       filename)))
 237
 238 (defmacro br-set-cons (set elt)
 239   "Add to SET element ELT.  Returns nil iff ELT is already in SET.
 240 Uses `equal' for comparison."
 241   (` (if (br-member (, elt) (, set))
 242          nil
 243        (setq (, set) (cons (, elt) (, set))))))
 244
 245 (if (fboundp 'temp-directory)
 246 (defalias 'br-temp-directory 'temp-directory)
 247 (defun br-temp-directory ()
 248   (let ((tmp-dir
 249          (file-name-as-directory
 250           (or (getenv "TMPDIR")
 251               (getenv "TMP")
 252               (getenv "TEMP")
 253               (if (file-directory-p "/tmp/") "/tmp/")
 254               (if (file-directory-p "C:/tmp/") "C:/tmp/")
 255               (if hyperb:microcruft-os-p
 256                   (condition-case ()
 257                       (progn (make-directory "C:/tmp/") "C:/tmp/")
 258                     (error (expand-file-name "~")))
 259                 (condition-case ()
 260                     (progn (make-directory "/tmp/") "/tmp/")
 261                   (error (expand-file-name "~"))))))))
 262     (if (file-writable-p tmp-dir)
 263         (progn (setenv "TMPDIR" tmp-dir) tmp-dir)
 264       (error "(br-temp-directory): Temp dir, \"%s\", is not writable."
 265              tmp-dir)))))
 266
 267 (defun br-wind-line-at-point ()
 268   "Return window relative line number that point is on."
 269   (max 0 (1- (- (count-lines 1 (min (1+ (point)) (point-max)))
 270                 (count-lines 1 (window-start))))))
 271
 272 ;;; ************************************************************************
 273 ;;; Browser public functions
 274 ;;; ************************************************************************
 275
 276 (defun br-add-class (class-name &optional class-path lib-table-p save-file)
 277   "Add or replace CLASS-NAME in current Environment.
 278   Find class source in optional CLASS-PATH.  Interactively or when optional
 279 CLASS-PATH is nil, defaults to current buffer file as CLASS-PATH.  If
 280 optional LIB-TABLE-P is non-nil, add to Library Environment, otherwise add to
 281 System Environment.  If optional SAVE-FILE is t, the Environment is then
 282 stored to filename given by `br-env-file'.  If SAVE-FILE is non-nil and
 283 not t, its string value is used as the file to which to save the Environment.
 284 Does not update children lookup table."
 285   (interactive
 286    (list (read-string "Class name to add: ")
 287          (read-file-name (concat "Class file name"
 288                                  (if buffer-file-name
 289                                      " (default <current file>)")
 290                                  ": ")
 291                          nil buffer-file-name t)
 292          (y-or-n-p "Add to Library, rather than System tables? ")
 293          (y-or-n-p
 294           (concat "Save tables after addition to " br-env-file "? "))))
 295   ;;
 296   ;; Pseudo code:
 297   ;;
 298   ;;    If class-name is in table
 299   ;;       If function called interactively
 300   ;;          Query whether should overwrite class-name in tables
 301   ;;          If yes
 302   ;;             Replace class and its features
 303   ;;          else
 304   ;;             Don't add class; do nothing
 305   ;;          end
 306   ;;       else
 307   ;;          Store class without its features in all necessary tables
 308   ;;       end
 309   ;;    else
 310   ;;       Store class and its features under key in all necessary tables
 311   ;;    end
 312   ;;
 313   (or class-path (setq class-path buffer-file-name)
 314       (error "No class pathname specified."))
 315   (if (or (string-equal class-name "")
 316           (not (or (equal class-path br-null-path)
 317                    (file-exists-p class-path))))
 318       (error "Invalid class specified, `%s', in: \"%s\"" class-name class-path))
 319   ;; Is class already in Environment?
 320   (if (hash-key-p class-name (br-get-htable
 321                               (if lib-table-p "lib-parents" "sys-parents")))
 322       (if (or (not (interactive-p))
 323               (y-or-n-p (format "Overwrite existing `%s' entry? " class-name)))
 324           (br-real-add-class lib-table-p class-name class-path t)
 325         (setq save-file nil))
 326     (br-real-add-class lib-table-p class-name class-path))
 327   (cond ((eq save-file nil))
 328         ((eq save-file t) (br-env-save))
 329         ((br-env-save save-file))))
 330
 331 (defun br-build-lib-htable ()
 332   "Build Library dependent Environment."
 333   (interactive)
 334   (cond ((and (interactive-p)
 335                (not (y-or-n-p "Rebuild Library Environment? ")))
 336          nil)
 337         (t
 338          (message "Building Library Environment...")
 339          (sit-for 2)
 340          (br-real-build-alists br-lib-search-dirs)
 341          (if (interactive-p) (br-feature-build-htables))
 342          (setq br-lib-paths-htable (hash-make br-paths-alist)
 343                br-lib-parents-htable (hash-make br-parents-alist))
 344          (run-hooks 'br-after-build-lib-hook)
 345          (br-env-set-htables)
 346          ;; Set prev-search-dirs so table rebuilds are not triggered.
 347          (setq br-lib-prev-search-dirs br-lib-search-dirs)
 348          (if (interactive-p) (br-env-save))
 349          (message "Building Library Environment...Done")
 350          t)))
 351
 352 (defun br-build-sys-htable ()
 353   "Build System dependent class Environment."
 354   (interactive)
 355   (cond ((and (interactive-p)
 356               (not (y-or-n-p "Rebuild System Environment? ")))
 357          nil)
 358         (t
 359          (message "Building System Environment...")
 360          (sit-for 2)
 361          (br-real-build-alists br-sys-search-dirs)
 362          (if (interactive-p) (br-feature-build-htables))
 363          (setq br-sys-paths-htable (hash-make br-paths-alist)
 364                br-sys-parents-htable (hash-make br-parents-alist))
 365          (run-hooks 'br-after-build-sys-hook)
 366          (br-env-set-htables)
 367          ;; Set prev-search-dirs so table rebuilds are not triggered.
 368          (setq br-sys-prev-search-dirs br-sys-search-dirs)
 369          (if (interactive-p) (br-env-save))
 370          (message "Building System Environment...Done")
 371          t)))
 372
 373 (defun br-class-in-table-p (class-name)
 374   "Return t iff CLASS-NAME is referenced within the current Environment."
 375   (interactive (list (br-complete-class-name)))
 376   (if class-name (hash-key-p class-name (br-get-parents-htable))))
 377
 378 ;;; The OO-Browser depends on the name of this next function; don't change it.
 379 (defun br-class-list-identity (class-list top-only-flag)
 380   class-list)
 381
 382 (defun br-class-path (class-name &optional insert)
 383   "Return full path, if any, to CLASS-NAME.
 384 With optional prefix argument INSERT non-nil, insert path at point.
 385 Only the first matching class is returned, so each CLASS-NAME should be
 386 unique. Set `br-lib/sys-search-dirs' properly before use."
 387   (interactive (list (br-complete-class-name)))
 388   (setq class-name (if class-name (br-set-case class-name)))
 389   (let* ((class-path)
 390          (class-htable (br-get-paths-htable)))
 391     (catch 'done
 392       (hash-map
 393        (function (lambda (val-key-cons)
 394                    (and (br-member class-name (car val-key-cons))
 395                         (setq class-path (br-select-path val-key-cons nil))
 396                         (throw 'done nil))))
 397        class-htable))
 398     (if (equal class-path br-null-path)
 399         (setq class-path nil))
 400     (and (interactive-p) (setq insert current-prefix-arg))
 401     (if (and insert class-path)
 402         (insert class-path)
 403       (if (interactive-p)
 404           (message
 405            (or class-path
 406                (format
 407                 "(OO-Browser):  No `%s' class found in `br-lib/sys-search-dirs'."
 408                 class-name)))))
 409     class-path))
 410
 411 (defun br-find-class (&optional class-name view-only other-win)
 412   "Display file of class text matching CLASS-NAME in VIEW-ONLY mode if non-nil.
 413 Return the line number of the start of the class displayed when successful, nil
 414 otherwise.  Can also signal an error when called interactively."
 415   (interactive)
 416   (and (interactive-p) (setq view-only current-prefix-arg))
 417   (let ((class-path)
 418         (info (equal br-lang-prefix "info-"))
 419         (found)
 420         (err))
 421     (setq class-name
 422           (or class-name (br-complete-class-name))
 423           class-path (br-class-path class-name))
 424     (cond
 425      (info (br-find-info-node class-path class-name (not view-only))
 426            (setq found (br-line-number)))
 427      (class-path
 428       (if (file-readable-p class-path)
 429           (progn (if view-only
 430                      (funcall br-view-file-function class-path other-win)
 431                    (funcall br-edit-file-function class-path other-win)
 432                    ;; Handle case of already existing buffer in
 433                    ;; read only mode.
 434                    (and buffer-read-only
 435                         (file-writable-p class-path)
 436                         (progn (setq buffer-read-only nil)
 437                                ;; Force mode-line redisplay
 438                                (set-buffer-modified-p
 439                                 (buffer-modified-p)))))
 440                  (br-major-mode)
 441                  (let ((opoint (point))
 442                        (case-fold-search)
 443                        (start)
 444                        (pmin (point-min))
 445                        (pmax (point-max)))
 446                    (widen)
 447                    (goto-char (point-min))
 448                    (if br-narrow-view-to-class
 449                        ;; Display file narrowed to definition of
 450                        ;; `class-name'.
 451                        (if (br-to-class-definition class-name)
 452                            ;; Narrow display to this class
 453                            (progn (narrow-to-region
 454                                    (progn (setq opoint
 455                                                 (goto-char
 456                                                  (match-beginning 0)))
 457                                           (br-back-over-comments)
 458                                           (setq start (point))
 459                                           (goto-char opoint)
 460                                           start)
 461                                    (progn (br-to-class-end)
 462                                           (point)))
 463                                   (goto-char opoint))
 464                          (goto-char opoint)
 465                          (narrow-to-region pmin pmax)
 466                          (setq err (format "(OO-Browser):  No `%s' in \"%s\""
 467                                            class-name class-path)))
 468                      (if (br-to-class-definition class-name)
 469                          (progn (setq opoint (goto-char (match-beginning 0)))
 470                                 (br-back-over-comments)
 471                                 (goto-char opoint))
 472                        (goto-char opoint)
 473                        (narrow-to-region pmin pmax)
 474                        (setq err (format "(OO-Browser):  No `%s' in %s" class-name
 475                                         class-path)))))
 476                  (if err nil (setq found (br-line-number))))
 477         (setq err (format "(OO-Browser):  %s's source file, \"%s\", was not found or was unreadable"
 478                           class-name class-path))))
 479      ((interactive-p)
 480       (setq err (format "(OO-Browser):  No `%s' class defined in Environment"
 481                         class-name))))
 482     (if err (error err))
 483     (if (interactive-p)
 484         (message "(OO-Browser):  `%s' class in \"%s\""
 485                  class-name (br-env-substitute-home class-path)))
 486     found))
 487
 488 (defun br-to-class-definition (class-name)
 489   "Search forward past the definition signature of CLASS-NAME within the current buffer.
 490 Return non-nil iff definition is found.  Leave match patterns intact after the search."
 491   (let ((class-def (br-class-definition-regexp class-name))
 492         (found))
 493     (while (and (setq found (re-search-forward class-def nil t))
 494                 (fboundp 'c-within-comment-p)
 495                 (save-match-data (c-within-comment-p)))
 496       (setq found nil))
 497     found))
 498
 499 (defun br-back-over-comments ()
 500   "Skip back over any preceding comments stopping if the current line would leave the window."
 501   (let ((opoint (point)))
 502     ;; Language-specific.
 503     (br-to-comments-begin)
 504     ;; The following elaborate conditional is true if moving back past the
 505     ;; comments has pushed the original display line outside of the window
 506     ;; bounds.  The simpler check of (window-end) is not used because
 507     ;; redisplay has not yet been run and thus (window-end) does not yet
 508     ;; recorded the updated value.  It is better to err on the high
 509     ;; side when subtracting lines from the (window-height) here to ensure
 510     ;; that the original line is displayed.
 511     (if (> (count-lines (point) opoint) (- (window-height) 3))
 512         (progn (goto-char opoint)
 513                ;; Make current line the last in the window in order to show as
 514                ;; much commentary as possible without scrolling the current
 515                ;; code line outside of the window.
 516                (recenter -1))
 517       (recenter 0))))
 518
 519 (defun br-line-number ()
 520   "Return the present absolute line number within the current buffer counting from 1."
 521   (save-excursion
 522     (beginning-of-line)
 523     (1+ (count-lines 1 (point)))))
 524
 525 (defun br-display-code (start)
 526   "Goto START, skip back past preceding comments and then display."
 527   (goto-char start)
 528   (skip-chars-forward " \t\n\r")
 529   (setq start (point))
 530   ;; If the definition line is at the end of a list,
 531   ;; e.g. following a closing brace, ensure that the
 532   ;; beginning of the expression is visible.
 533   (beginning-of-line)
 534   (if (looking-at "[ \t]*\\s\)")
 535       (progn (goto-char (match-end 0))
 536              (condition-case ()
 537                  (progn (backward-list 1)
 538                         (beginning-of-line))
 539                (error nil))))
 540   (br-back-over-comments)
 541   (goto-char start)
 542   t)
 543
 544 (defun br-major-mode ()
 545   "Invoke language-specific major mode on current buffer if not already set."
 546   (or (eq major-mode (symbol-function 'br-lang-mode))
 547       ;; directory
 548       (not buffer-file-name)
 549       (br-lang-mode)))
 550
 551 (defun br-class-category-p (name)
 552   "Return (category) if NAME contains a class category."
 553   (and (string-equal br-lang-prefix "objc-")
 554        (string-match "\([^\)]+\)" name)
 555        (substring name (match-beginning 0) (match-end 0))))
 556
 557 (defalias 'br-protocol-support-p 'br-interface-support-p)
 558 (defun br-interface-support-p ()
 559   "Return t if the present OO-Browser Environment language contains interface (protocol) browsing support."
 560   (if (br-member br-lang-prefix '("java-" "objc-")) t))
 561
 562 (defalias 'br-protocol-p 'br-interface-p)
 563 (defun br-interface-p (class-name)
 564   "Return CLASS-NAME if it is an interface or protocol which specifies method interfaces to which classes conform, else nil.
 565 In Java, these are called interfaces.  In Objective-C, they are called protocols."
 566   (and (br-interface-support-p)
 567        (eq (aref class-name 0) ?\<)
 568        class-name))
 569
 570 (defun br-default-class-p (class-name)
 571   "Return CLASS-NAME if it is a default class, one generated by the OO-Browser, else nil."
 572   (if (eq (aref class-name 0) ?\[) class-name))
 573
 574 (defun br-concrete-class-p (class-name)
 575   "Return CLASS-NAME if it is not an interface or protocol, which generally means that all methods are implemented, else nil."
 576   (if (not (br-interface-p class-name)) class-name))
 577
 578 (defun br-scan-mode ()
 579   "Invoke language-specific major mode for current buffer without running its hooks.
 580 This is used when scanning source files to build Environments."
 581   (let ((mode-hook-sym
 582           (intern-soft (concat (symbol-name (symbol-function 'br-lang-mode))
 583                                "-hook"))))
 584     (if mode-hook-sym
 585         (eval (` (let ((, mode-hook-sym)) (br-lang-mode))))
 586       (br-lang-mode))))
 587
 588 (defun br-show-children (class-name)
 589   "Return children of CLASS-NAME from current Environment."
 590   (interactive (list (br-complete-class-name t)))
 591   (and class-name
 592        (br-get-children class-name)))
 593
 594 (defun br-show-parents (class-name)
 595   "Return parents of CLASS-NAME from Environment or scan of current buffer's source."
 596   (interactive (list (br-complete-class-name t)))
 597   (if class-name
 598       (if (br-class-in-table-p class-name)
 599           (br-get-parents class-name)
 600         (if (and buffer-file-name (file-readable-p buffer-file-name))
 601             (let ((br-view-file-function 'br-insert-file-contents))
 602               (br-get-parents-from-source buffer-file-name class-name))))))
 603
 604 (defun br-undefined-classes ()
 605   "Return a list of the classes referenced but not defined within the current Environment."
 606   (let ((classes (hash-get br-null-path (br-get-paths-htable))))
 607     (delq nil (mapcar (function (lambda (class)
 608                                   ;; Remove default classes
 609                                   (if (not (eq (aref class 0) ?\[))
 610                                       class)))
 611                       classes))))
 612
 613 ;;; ************************************************************************
 614 ;;; Private functions
 615 ;;; ************************************************************************
 616
 617 (defun br-add-to-paths-htable (class-name paths-key htable)
 618   "Add CLASS-NAME under PATHS-KEY in paths lookup HTABLE."
 619   (let ((other-classes (hash-get paths-key htable)))
 620     (if (and other-classes (br-member class-name other-classes))
 621         nil
 622       (hash-add (cons class-name other-classes) paths-key htable))))
 623
 624 (defun br-build-lib-parents-htable ()
 625   (interactive)
 626   (if (not br-lib-search-dirs)
 627       nil
 628     (message "Building Library parents...")
 629     (sit-for 2)
 630     (if br-lib-paths-htable
 631         (setq br-lib-parents-htable
 632               (hash-make
 633                (br-real-build-parents-alist br-lib-paths-htable)))
 634       (br-real-build-alists br-lib-search-dirs)
 635       (br-feature-build-htables)
 636       (setq br-lib-parents-htable (hash-make br-parents-alist)))
 637     (if (interactive-p) (br-env-save))
 638     (message "Building Library parents...Done")))
 639
 640 (defun br-build-lib-paths-htable ()
 641   (interactive)
 642   (if (not br-lib-search-dirs)
 643       nil
 644     (message "Building Library paths...")
 645     (sit-for 2)
 646     (br-real-build-alists br-lib-search-dirs)
 647     (br-feature-build-htables)
 648     (setq br-lib-paths-htable (hash-make br-paths-alist))
 649     (if (interactive-p) (br-env-save))
 650     (message "Building Library paths...Done")))
 651
 652 (defun br-build-sys-parents-htable ()
 653   (interactive)
 654   (if (not br-sys-search-dirs)
 655       nil
 656     (message "Building System parents...")
 657     (sit-for 2)
 658     (if br-sys-paths-htable
 659         (setq br-sys-parents-htable
 660               (hash-make
 661                (br-real-build-parents-alist br-sys-paths-htable)))
 662       (br-real-build-alists br-sys-search-dirs)
 663       (br-feature-build-htables)
 664       (setq br-sys-parents-htable
 665             (hash-make br-parents-alist)))
 666     (if (interactive-p) (br-env-save))
 667     (message "Building System parents...Done")))
 668
 669 (defun br-build-sys-paths-htable ()
 670   (interactive)
 671   (if (not br-sys-search-dirs)
 672       nil
 673     (message "Building System paths...")
 674     (sit-for 2)
 675     (br-real-build-alists br-sys-search-dirs)
 676     (br-feature-build-htables)
 677     (setq br-sys-paths-htable (hash-make br-paths-alist))
 678     (if (interactive-p) (br-env-save))
 679     (message "Building System paths...Done")))
 680
 681 (defun br-build-children-htable ()
 682   (interactive)
 683   (setq br-children-htable (br-real-build-children-htable))
 684   (if (interactive-p) (br-env-save)))
 685
 686 (defun br-build-parents-htable ()
 687   (interactive)
 688   (br-build-sys-parents-htable)
 689   (br-build-lib-parents-htable)
 690   ;; Make System entries override Library entries which they duplicate, since
 691   ;; this is generally more desireable than merging the two.
 692   (br-merge-parents-htables)
 693   (if (interactive-p) (br-env-save)))
 694
 695 (defun br-merge-parents-htables ()
 696   (let ((hash-merge-values-function 'hash-merge-first-value))
 697     (setq br-parents-htable (hash-merge br-sys-parents-htable
 698                                         br-lib-parents-htable))))
 699
 700 (defun br-build-paths-htable ()
 701   (interactive)
 702   (br-build-sys-paths-htable)
 703   (br-build-lib-paths-htable)
 704   (br-merge-paths-htables)
 705   (if (interactive-p) (br-env-save)))
 706
 707 (defun br-merge-paths-htables ()
 708   (setq br-paths-htable (hash-merge br-sys-paths-htable br-lib-paths-htable))
 709   ;;
 710   ;; We may have merged two tables where a single class-name was referenced
 711   ;; in one and defined in the other which means it will have both a path
 712   ;; entry and a br-null-path entry; remove the latter.
 713   (let ((null-path-classes (hash-get br-null-path br-paths-htable))
 714         (null-lib-classes (sort (hash-get br-null-path br-lib-paths-htable)
 715                                 'string-lessp))
 716         (null-sys-default-classes
 717          (delq nil
 718                (mapcar (function (lambda (class)
 719                                    (if (br-default-class-p class) class)))
 720                        (hash-get br-null-path br-sys-paths-htable))))
 721         (null-sys-referenced-classes
 722          ;; Eliminates default classes; need this for System classes only
 723          ;; since default classes are not added to the Library hash tables.
 724          (sort
 725           (delq nil
 726                 (mapcar (function (lambda (class)
 727                                     (if (br-default-class-p class) nil class)))
 728                         (hash-get br-null-path br-sys-paths-htable)))
 729           'string-lessp)))
 730     (unwind-protect
 731         (progn (hash-delete br-null-path br-paths-htable)
 732                (setq null-path-classes
 733                      (delq nil
 734                            (mapcar
 735                             (function
 736                              (lambda (class)
 737                                (if (or (br-default-class-p class)
 738                                        (not (br-class-path class)))
 739                                    class
 740                                  ;; Class path exists, but we may need to
 741                                  ;; remove a null entry from the Library or
 742                                  ;; System table if it was referenced but not
 743                                  ;; defined in one of these.
 744                                  (setq null-lib-classes
 745                                        (br-delete-sorted-strings
 746                                         class null-lib-classes))
 747                                  (setq null-sys-referenced-classes
 748                                        (br-delete-sorted-strings
 749                                         class null-sys-referenced-classes))
 750                                  nil)))
 751                             null-path-classes))))
 752       (if null-path-classes
 753           (hash-add null-path-classes br-null-path br-paths-htable)
 754         (hash-delete br-null-path br-paths-htable))
 755       (if null-lib-classes
 756           (hash-add null-lib-classes br-null-path br-lib-paths-htable)
 757         (hash-delete br-null-path br-lib-paths-htable))
 758       (let ((null-sys-classes (nconc null-sys-default-classes
 759                                      null-sys-referenced-classes)))
 760         (if null-sys-classes
 761             (hash-add null-sys-classes br-null-path br-sys-paths-htable)
 762           (hash-delete br-null-path br-sys-paths-htable))))))
 763
 764 (defun br-class-defined-p (class)
 765   "Return path for CLASS if defined in current Environment.
 766 Otherwise, display error and return nil."
 767   (or (br-class-path class)
 768       (progn
 769         (beep)
 770         (message
 771          (if (br-class-in-table-p class)
 772              (format "(OO-Browser):  Class `%s' referenced but not defined in Environment."
 773                      class)
 774            (format "(OO-Browser):  Class `%s' not defined in Environment."
 775                    class)))
 776         nil)))
 777
 778 (defun br-check-for-class (cl &optional other-win)
 779   "Try to display class CL.
 780 Display message and return nil if unsucessful."
 781   (if (br-class-in-table-p cl)
 782       (or (br-find-class cl nil other-win)
 783           (progn
 784             (beep)
 785             (message
 786              (format "(OO-Browser):  Class `%s' referenced but not defined in Environment."
 787                      cl))
 788             t))))
 789
 790 (defun br-get-parents (class-name)
 791   "Return list of parents of CLASS-NAME from parent lookup table.
 792 Those from which CLASS-NAME directly inherits."
 793   (setq class-name (if class-name (br-set-case class-name)))
 794   (br-set-of-strings (hash-get class-name (br-get-parents-htable))))
 795
 796 (defun br-get-children (class-name)
 797   "Return list of children of CLASS-NAME from child lookup table.
 798 Those which directly inherit from CLASS-NAME."
 799   (setq class-name (if class-name (br-set-case class-name)))
 800   (br-set-of-strings (hash-get class-name (br-get-children-htable))))
 801
 802 (defun br-get-children-from-parents-htable (class-name)
 803   "Returns list of children of CLASS-NAME.
 804 Those that directly inherit from CLASS-NAME.  Uses parent lookup table to
 805 compute children."
 806   (setq class-name (and class-name (br-set-case class-name)))
 807   (delq nil (hash-map (function (lambda (cns)
 808                                   (if (and (consp cns)
 809                                            (br-member class-name (car cns)))
 810                                       (cdr cns))))
 811                       (br-get-parents-htable))))
 812
 813 (defun br-get-htable (htable-type)
 814   "Returns hash table corresponding to string, HTABLE-TYPE.
 815 When necessary, loads the hash table from a file or builds it."
 816   (let* ((htable-symbol (intern-soft (concat "br-" htable-type "-htable")))
 817          (htable-specific (if (string-match "sys\\|lib" htable-type)
 818                               (substring htable-type (match-beginning 0)
 819                                          (match-end 0))))
 820          changed-types non-matched-types)
 821     (if (equal htable-type "children")
 822         nil
 823       (if (and (or (not htable-specific) (equal htable-specific "lib"))
 824                (or (null (symbol-value htable-symbol))
 825                    (not (equal br-lib-prev-search-dirs br-lib-search-dirs))))
 826           (setq changed-types '("lib")))
 827       (if (and (or (not htable-specific) (equal htable-specific "sys"))
 828                (or (null (symbol-value htable-symbol))
 829                    (not (equal br-sys-prev-search-dirs br-sys-search-dirs))))
 830           (setq changed-types (cons "sys" changed-types))))
 831     (if (and (or br-lib-search-dirs br-sys-search-dirs)
 832              (or changed-types (null (symbol-value htable-symbol)))
 833              (not (boundp 'br-loaded)))
 834         ;;
 835         ;; Then need to load or rebuild htable.
 836         ;;
 837         (progn (if (and br-env-file
 838                         (file-exists-p br-env-file))
 839                    ;;
 840                    ;; Try to load from file.
 841                    ;;
 842                    (progn (setq non-matched-types
 843                                 (br-env-load-matching-htables changed-types))
 844                           (if non-matched-types
 845                               (setq changed-types
 846                                     (delq nil (mapcar
 847                                                (function
 848                                                 (lambda (type)
 849                                                   (if (br-member type
 850                                                                  changed-types)
 851                                                       type)))
 852                                                non-matched-types)))
 853                             (and changed-types (br-env-set-htables t))
 854                             (setq changed-types nil)
 855                             (cond (htable-specific)
 856                                   ((equal htable-type "children")
 857                                    (progn (goto-char (point-min))
 858                                           (setq br-children-htable
 859                                                 (cdr (br-env-file-sym-val
 860                                                       "br-children-htable")))))
 861                                   ((let ((suffix
 862                                           (concat "-" htable-type "-htable"))
 863                                          (hash-merge-values-function
 864                                           'hash-merge-values))
 865                                          ;; Make System entries override
 866                                          ;; Library entries which they
 867                                          ;; duplicate, if this is the parents
 868                                          ;; htable.
 869                                      (if (equal htable-type "parents")
 870                                          (setq hash-merge-values-function
 871                                                'hash-merge-first-value))
 872                                      (set htable-symbol
 873                                           (hash-merge
 874                                            (symbol-value
 875                                             (intern-soft
 876                                              (concat "br-sys" suffix)))
 877                                            (symbol-value
 878                                             (intern-soft
 879                                              (concat
 880                                               "br-lib" suffix)))
 881                                            ))))))))
 882                ;; Rebuild any lists that need to be changed.
 883                (mapcar
 884                 (function
 885                  (lambda (type-str)
 886                    (let ((suffix (concat "-" htable-type "-htable")))
 887                      (funcall (intern-soft
 888                                (if (string-match "sys\\|lib" htable-type)
 889                                    (concat "br-build" suffix)
 890                                  (concat "br-build-" type-str suffix))))
 891                      (and htable-specific
 892                           ;; Make System entries override Library entries
 893                           ;; which they duplicate, if this is the parents
 894                           ;; htable.
 895                           (let ((hash-merge-values-function
 896                                  'hash-merge-values))
 897                             (if (equal htable-type "parents")
 898                                 (setq hash-merge-values-function
 899                                       'hash-merge-first-value))
 900                             (set htable-symbol
 901                                  (hash-merge (symbol-value
 902                                               (intern-soft
 903                                                (concat "br-sys" suffix)))
 904                                              (symbol-value
 905                                               (intern-soft
 906                                                (concat "br-lib" suffix)))
 907                                              )))))))
 908                 changed-types)
 909                (if (and changed-types br-env-file)
 910                    (br-env-save))
 911                (let ((buf (get-file-buffer br-env-file)))
 912                  (and buf (kill-buffer buf)))))
 913     ;; Return non-nil hash table.
 914     (if (null (symbol-value htable-symbol))
 915         (set htable-symbol (hash-make 0))
 916       (symbol-value htable-symbol))))
 917
 918 (defun br-get-top-class-list (htable-type-str)
 919     "Returns unordered list of top-level classes.
 920 Those that do not explicitly inherit from any other classes.  Obtains classes
 921 from list denoted by HTABLE-TYPE-STR whose values may be:
 922 \"parents\", \"sys-parents\", or \"lib-parents\"."
 923     (delq nil (hash-map (function
 924                           (lambda (cns)
 925                             (if (null (car cns)) (cdr cns))))
 926                         (br-get-htable htable-type-str))))
 927
 928 (defun br-get-top-classes ()
 929   "Returns lexicographically ordered list of top-level classes.
 930 Those that do not explicitly inherit from any other classes."
 931   (br-get-top-class-list "parents"))
 932
 933 (defun br-get-lib-top-classes ()
 934   "Returns lexicographically ordered list of top-level Library classes.
 935 Those that do not explicitly inherit from any other classes."
 936   (br-get-top-class-list "lib-parents"))
 937
 938 (defun br-get-sys-top-classes ()
 939   "Returns lexicographically ordered list of top-level System classes.
 940 Those that do not explicitly inherit from any other classes."
 941   (br-get-top-class-list "sys-parents"))
 942
 943 (defun br-has-children-p (class-name)
 944   "Return non-nil iff CLASS-NAME has at least one child.
 945 That is a class that directly inherits from CLASS-NAME."
 946   (setq class-name (and class-name (br-set-case class-name)))
 947   (hash-get class-name (br-get-children-htable)))
 948
 949 (defun br-has-parents-p (class-name)
 950   "Return non-nil iff CLASS-NAME has at least one parent.
 951 That is a class which is a direct ancestor of CLASS-NAME."
 952   (setq class-name (and class-name (br-set-case class-name)))
 953   (hash-get class-name (br-get-parents-htable)))
 954
 955 (defun br-get-process-group (group max)
 956   "Return list of all active processes in GROUP (a string).
 957 MAX is max number of processes to check for."
 958   (let ((i 0)
 959         (proc-list))
 960     (while (<= i max)
 961       (setq i (1+ i)
 962             proc-list (cons (get-process (concat group (int-to-string i)))
 963                             proc-list)))
 964     (delq nil proc-list)))
 965
 966
 967 (defun br-kill-process-group (group max group-descrip)
 968   "Optionally question user, then kill all subprocesses in named GROUP.
 969 Processes are numbered one to MAX, some of which may have been killed already.
 970 User is prompted with a string containing GROUP-DESCRIP, only if non-nil.
 971 Return list of processes killed."
 972   (let ((proc-list (br-get-process-group group max)))
 973     (if proc-list
 974         (if (or (null group-descrip)
 975                 (y-or-n-p (concat "Terminate all " group-descrip "? ")))
 976             (prog1 (mapcar 'delete-process proc-list)
 977               (message ""))))))
 978
 979 (defun br-real-add-class (lib-table-p class-name class-path &optional replace)
 980   "Add or replace class and its features within the current Environment.
 981 If LIB-TABLE-P is non-nil, add to Library Environment, otherwise add to
 982 System Environment.  Add class CLASS-NAME located in CLASS-PATH to
 983 Environment.  If CLASS-PATH is nil, use current buffer file as CLASS-PATH.
 984 Optional REPLACE non-nil means replace already existing class.  Does not
 985 update children lookup table."
 986   (or class-path (setq class-path buffer-file-name))
 987   (let ((par-list)
 988         (paths-key class-path)
 989         (func)
 990         (class class-name))
 991     (if replace
 992         (setq func 'hash-replace
 993               class-name (br-first-match
 994                           (concat "^" (regexp-quote class-name) "$")
 995                           (hash-get paths-key
 996                                     (if lib-table-p
 997                                         (br-get-htable "lib-paths")
 998                                       (br-get-htable "sys-paths"))))
 999               par-list
1000               (and (stringp class-path) (file-readable-p class-path)
1001                    (let ((br-view-file-function 'br-insert-file-contents))
1002                      (br-get-parents-from-source class-path class-name))))
1003       (setq func 'hash-add))
1004     ;; Signal error if class-name is invalid.
1005     (if (null class-name)
1006         (if replace
1007             (error "(br-real-add-class): `%s' not found in %s classes, so cannot replace it."
1008                    class (if lib-table-p "Library" "System"))
1009           (error
1010            "(br-real-add-class): Attempt to add null class to %s classes."
1011            (if lib-table-p "Library" "System"))))
1012     ;;
1013     (mapcar
1014      (function
1015       (lambda (type)
1016         (let ((par-htable (br-get-htable (concat type "parents")))
1017               (path-htable (br-get-htable (concat type "paths"))))
1018           (funcall func par-list class-name par-htable)
1019           (br-add-to-paths-htable class-name paths-key path-htable))))
1020      (list (if lib-table-p "lib-" "sys-") ""))
1021     (and (stringp class-path) (file-readable-p class-path)
1022          (let ((br-view-file-function 'br-insert-file-contents))
1023            (br-get-classes-from-source class-path)))))
1024
1025 (defun br-real-delete-class (class-name)
1026   "Delete class CLASS-NAME from current Environment.
1027 No error occurs if the class is undefined in the Environment."
1028   (require 'set)
1029   (br-feature-tags-delete class-name)
1030   (let ((paths-key (br-class-path class-name))
1031         htable)
1032     (setq class-name
1033           (br-first-match (concat "^" class-name "$")
1034                           (hash-get paths-key (br-get-paths-htable))))
1035     (if class-name
1036         (progn (mapcar
1037                  (function
1038                    (lambda (type)
1039                     (hash-delete class-name
1040                                  (br-get-htable (concat type "parents")))
1041                     (setq htable (br-get-htable (concat type "paths")))
1042                     (if (hash-key-p paths-key htable)
1043                         (hash-replace
1044                          (set:remove
1045                           class-name
1046                           (hash-get paths-key htable))
1047                          paths-key htable))))
1048                  '("lib-" "sys-" ""))
1049                (hash-delete class-name (br-get-children-htable))
1050                (if (hashp br-features-htable)
1051                    (hash-delete class-name br-features-htable))))))
1052
1053 (defun br-real-build-children-htable ()
1054   "Build and return Environment parent to child lookup table."
1055   (let* ((par-ht (br-get-parents-htable))
1056          (htable (hash-make (hash-size par-ht)))
1057          (child))
1058     (hash-map
1059       (function
1060         (lambda (par-child-cns)
1061           (setq child (cdr par-child-cns))
1062           (mapcar
1063             (function
1064               (lambda (parent)
1065                 (hash-add
1066                   (cons child (hash-get parent htable))
1067                   parent htable)))
1068             (car par-child-cns))))
1069       par-ht)
1070     (hash-map (function
1071                 (lambda (children-parent-cns)
1072                   (hash-replace (sort (car children-parent-cns) 'string-lessp)
1073                                 (cdr children-parent-cns) htable)))
1074               htable)
1075     htable))
1076
1077 (defun br-real-get-children (class-name)
1078   "Return list of child classes of CLASS-NAME listed in Environment parents htable."
1079   (delq nil (hash-map
1080               (function
1081                 (lambda (cns)
1082                   (if (and (consp cns)
1083                            (br-member class-name (car cns)))
1084                       (cdr cns))))
1085               (br-get-parents-htable))))
1086
1087 (defun br-real-build-alists (search-dirs)
1088   "Use SEARCH-DIRS to build `br-paths-alist' and `br-parents-alist'."
1089   (setq br-paths-alist nil br-parents-alist nil)
1090   (br-feature-tags-init nil)
1091   ;; These locals are used as free variables in the `br-real-build-al'
1092   ;; function. We define them here to prevent repeated stack usage as
1093   ;; that function recurses.
1094   (let ((inhibit-local-variables nil)
1095         (enable-local-variables t)
1096         (files)
1097         ;; Treat as though running in batch mode so that major-mode-specific
1098         ;; messages (e.g. those in Python mode) may be suppressed as files
1099         ;; are read in for scanning.
1100         (noninteractive t)
1101         ;; These are used in the `br-search-directory' function
1102         ;; called by `br-real-built-al'.
1103         (br-view-file-function 'br-insert-file-contents)
1104         classes parents paths-parents-cons)
1105     (br-real-build-al search-dirs nil
1106                       (if (string-equal br-lang-prefix "python-")
1107                           'python-search-directory
1108                         'br-search-directory)))
1109   (setq br-paths-alist br-paths-alist)
1110   br-paths-alist)
1111
1112 (defvar br-paths-alist nil)
1113 (defvar br-parents-alist nil)
1114
1115 (defun br-skip-dir-p (dir-name)
1116   "Returns non-nil iff DIR-NAME is matched by a member of `br-skip-dir-regexps'."
1117   (delq nil
1118         (mapcar (function
1119                  (lambda (dir-regexp)
1120                    (string-match dir-regexp
1121                                  (file-name-nondirectory
1122                                   (directory-file-name dir-name)))))
1123                 br-skip-dir-regexps)))
1124
1125 (defun br-real-build-al (search-dirs subdirectories-flag search-dir-func)
1126   "Descend SEARCH-DIRS and build `br-paths-alist' and `br-parents-alist'.
1127 SUBDIRECTORIES-FLAG is t when SEARCH-DIRS are subdirectories of the root
1128 Environment search directories.  SEARCH-DIR-FUNC is the function which
1129 processes each directory, generally `br-search-directory'.
1130 Does not initialize `br-paths-alist' or `br-parents-alist' to nil."
1131   (mapcar
1132    (function
1133     (lambda (dir)
1134       (if (or (null dir) (equal dir "")
1135               (progn (setq dir (file-name-as-directory dir))
1136                      ;; Skip subdirectory symlinks but not root-level ones.
1137                      (and subdirectories-flag
1138                           (file-symlink-p (directory-file-name dir))))
1139               (br-skip-dir-p dir))
1140           nil
1141         (setq files (if (and (file-directory-p dir)
1142                              (file-readable-p dir))
1143                         (directory-files dir t br-file-dir-regexp)))
1144         ;; Extract all class/parent names in all source files in a
1145         ;; particular directory.
1146         (if files
1147             (progn (message "Scanning %s in %s ..."
1148                             (file-name-nondirectory
1149                              (directory-file-name dir))
1150                             (br-abbreviate-file-name
1151                              (or (file-name-directory
1152                                   (directory-file-name dir))
1153                                  "")))
1154                    (funcall search-dir-func dir files)
1155                    ;; Call same function on all the directories below
1156                    ;; this one.
1157                    (br-real-build-al
1158                     (mapcar (function (lambda (f)
1159                                         (if (file-directory-p f) f)))
1160                             files)
1161                     t search-dir-func))))))
1162    search-dirs))
1163
1164 (defun br-search-directory (dir files)
1165   (mapcar
1166    (function
1167     (lambda (f)
1168       (if (file-readable-p f)
1169           (progn (message "Scanning %s in %s ..."
1170                           (file-name-nondirectory f)
1171                           (br-abbreviate-file-name
1172                            (or (file-name-directory f) default-directory)))
1173                  (setq paths-parents-cons
1174                        (br-get-classes-from-source f nil t)
1175                        classes (car paths-parents-cons)
1176                        parents (cdr paths-parents-cons)
1177                        br-paths-alist
1178                        (if classes
1179                            (cons (cons classes f) br-paths-alist)
1180                          br-paths-alist)
1181                        br-parents-alist (if parents
1182                                             (append br-parents-alist
1183                                                     parents)
1184                                           br-parents-alist)))
1185         ;; else
1186         (message "(OO-Browser):  Unreadable file: %s in %s"
1187                  (file-name-nondirectory f)
1188                  (br-abbreviate-file-name
1189                   (or (file-name-directory f) default-directory)))
1190         (sit-for 1))))
1191    ;; List of files potentially containing classes.
1192    (delq nil
1193          (mapcar
1194           (function
1195            (lambda (f)
1196              (and (string-match br-src-file-regexp f)
1197                   (not (file-directory-p f))
1198                   f)))
1199           files))))
1200
1201 (defun br-real-build-parents-alist (paths-htable)
1202   "Build and return `br-parents-alist' of (parent-list . class) elements built from PATHS-HTABLE.
1203 Initializes `br-parents-alist' to nil."
1204   (let ((inhibit-local-variables nil)
1205         (enable-local-variables t)
1206         (br-view-file-function 'br-insert-file-contents)
1207         dir)
1208     (hash-map
1209      (function
1210       (lambda (classes-file-cons)
1211         (setq dir (cdr classes-file-cons))
1212         (mapcar
1213          (function
1214           (lambda (class-name)
1215             (setq br-parents-alist
1216                   (cons (cons
1217                          (and (stringp dir)
1218                               (file-exists-p dir)
1219                               (sort
1220                                (br-get-parents-from-source
1221                                 dir class-name)
1222                                'string-lessp))
1223                          class-name)
1224                         br-parents-alist))))
1225          (car classes-file-cons))))
1226      paths-htable))
1227   br-parents-alist)
1228
1229 (defun br-set-lang-env (func sym-list val)
1230   "Use FUNC to set each element in SYM-LIST.
1231 If VAL is non-nil, set `br' element to the value of the current OO-Browser
1232 language element with the same name, otherwise set it to a function that
1233 when called signals an error that the function is undefined for this language."
1234   (let ((br) (lang))
1235     (mapcar (function
1236              (lambda (nm)
1237                (setq br   (intern (concat "br-" nm))
1238                      lang (intern-soft (concat br-lang-prefix nm)))
1239                (if (and (or (null lang) (not (boundp lang)))
1240                         val)
1241                    ;; Don't try to set an unbound language-specific variable.
1242                    nil
1243                  (funcall func br (if val
1244                                       (symbol-value lang)
1245                                     (or lang 'br-undefined-function))))))
1246             sym-list)))
1247
1248 (defun br-undefined-function (&rest ignore)
1249   (interactive)
1250   (error "(OO-Browser):  That command is not supported for this language."))
1251
1252 (defun br-setup-functions ()
1253   "Initialize appropriate function pointers for the current browser language."
1254   (br-set-lang-env 'fset
1255                    '("class-definition-regexp" "class-list-filter"
1256                      "get-classes-from-source" "get-parents-from-source"
1257                      "insert-class-info" "insert-entry-info"
1258                      "set-case" "set-case-type"
1259                      "store-class-info" "store-entry-info"
1260                      "to-class-end" "to-comments-begin" "to-definition"
1261                      "select-path"
1262
1263                      "feature-edit-declaration"
1264                      "feature-implementors"
1265                      "feature-locate-p" "feature-name-to-regexp"
1266                      "feature-normalize"
1267                      "feature-signature-to-name"
1268                      "feature-signature-to-regexp"
1269                      "feature-view-declaration" "list-categories"
1270                      "list-protocols" "view-friend")
1271                    nil))
1272
1273 (defun br-setup-constants (env-file)
1274   "Initialize appropriate constant values for the current browser language using ENV-FILE."
1275   ;; Initialize auxiliary Env file variables.
1276   (br-init env-file)
1277   ;; Clear language-dependent hooks.
1278   (setq br-after-build-lib-hook nil
1279         br-after-build-sys-hook nil)
1280   ;; Set language-specific constants.
1281   (br-set-lang-env 'set '("class-def-regexp" "env-file"
1282                           "identifier" "identifier-chars"
1283                           "src-file-regexp" "narrow-view-to-class"
1284                           "tag-fields-regexp" "type-tag-separator")
1285                    t)
1286   (if (not (eq br-env-name t))
1287       (br-set-lang-env 'set '("env-name") t)))
1288
1289 (defun br-find-info-node (filename node edit)
1290   "Show (FILENAME)NODE in current window.
1291 If EDIT is non-nil, NODE is made editable."
1292   (if (string-match "-[1-9][0-9]*$" filename)
1293       (setq filename (substring filename 0 (match-beginning 0))) )
1294   (Info-find-node filename node t)
1295   (if edit (let ((Info-enable-edit t))
1296              (Info-edit))))
1297
1298 ;;; ************************************************************************
1299 ;;; Private variables
1300 ;;; ************************************************************************
1301
1302 (defvar br-lib-search-dirs nil
1303   "List of directories below which library dirs and source files are found.
1304 A library is a stable group of classes.  Value is language-specific.")
1305 (defvar br-sys-search-dirs nil
1306   "List of directories below which system dirs and source files are found.
1307 A system is a group of classes that are likely to change.  Value is
1308 language-specific.")
1309
1310 (defvar br-lib-prev-search-dirs nil
1311   "Used to check if `br-lib-paths-htable' must be regenerated.
1312 Value is language-specific.")
1313 (defvar br-sys-prev-search-dirs nil
1314   "Used to check if `br-sys-paths-htable' must be regenerated.
1315 Value is language-specific.")
1316
1317 (defun br-pop-to-buffer (bufname &optional other-win read-only)
1318   "Display BUFNAME for editing, creating a new buffer if needed.
1319 Optional OTHER-WIN means show in other window unless Hyperbole
1320 is loaded in which case `hpath:display-buffer' determines where
1321 to display the buffer.  Optional READ-ONLY means make the buffer
1322 read-only."
1323   (interactive "BEdit or create buffer named: ")
1324   (funcall (cond ((br-in-browser)
1325                   (br-to-view-window)
1326                   (hpath:push-tag-mark)
1327                   'switch-to-buffer)
1328                  ((fboundp 'hpath:display-buffer)
1329                   'hpath:display-buffer)
1330                  (other-win 'switch-to-buffer-other-window)
1331                  (t 'switch-to-buffer))
1332            (get-buffer-create bufname))
1333   (if read-only (setq buffer-read-only t)))
1334
1335 (defun br-find-file (filename &optional other-win read-only)
1336   "Edit file FILENAME.
1337 Switch to a buffer visiting file FILENAME, creating one if none already
1338 exists.  Optional OTHER-WIN means show in other window unless Hyperbole is
1339 loaded in which case `hpath:display-buffer' determines where to display the
1340 file.  Optional READ-ONLY means make the buffer read-only."
1341   (interactive "FFind file: ")
1342   (funcall (cond ((br-in-browser)
1343                   (br-to-view-window)
1344                   (hpath:push-tag-mark)
1345                   'switch-to-buffer)
1346                  ((fboundp 'hpath:display-buffer)
1347                   'hpath:display-buffer)
1348                  (other-win 'switch-to-buffer-other-window)
1349                  (t 'switch-to-buffer))
1350            (find-file-noselect filename))
1351   (if read-only (setq buffer-read-only t)))
1352
1353 (defun br-find-file-read-only (filename &optional other-win)
1354   "Display file FILENAME read-only.
1355 Switch to a buffer visiting file FILENAME, creating one if none
1356 already exists.  Optional OTHER-WIN means show in other window."
1357   (interactive "FFind file read-only: ")
1358   (br-find-file filename other-win t))
1359
1360 (defvar br-edit-file-function 'br-find-file
1361   "*Function to call to edit a class file within the browser.")
1362 (defvar br-view-file-function
1363   (if (eq br-edit-file-function 'br-find-file)
1364       'br-find-file-read-only
1365     br-edit-file-function)
1366   "*Function to call to view a class file within the browser.")
1367
1368 (defvar br-find-file-noselect-function 'br-find-file-noselect
1369   "Function to call to load a browser file but not select it.
1370 The function must return the buffer containing the file's contents.")
1371
1372 (defvar *br-tmp-buffer* " oo-browser-tmp"
1373   "Name of temporary buffer used by the OO-Browser for parsing source files.")
1374
1375 (defun br-find-file-noselect (filename)
1376   "Read in the file given by FILENAME without selecting it or running any `find-file-hooks'."
1377   (let (find-file-hooks)
1378     (find-file-noselect filename)))
1379
1380 (defun br-insert-file-contents (filename &optional unused)
1381   "Insert after point into a temporary buffer the contents of FILENAME and temporarily select the buffer.
1382 Optional second arg UNUSED is necessary since when used as a setting for
1383 `br-view-file-function' this may be sent two arguments.
1384
1385 Does not run any find-file or mode specific hooks.  Marks buffer read-only to
1386 prevent any accidental editing.
1387
1388 Set `br-view-file-function' to this function when parsing OO-Browser source
1389 files for fast loading of many files."
1390   (set-buffer (get-buffer-create *br-tmp-buffer*))
1391   ;; Don't bother saving anything for this temporary buffer
1392   (buffer-disable-undo (current-buffer))
1393   (setq buffer-auto-save-file-name nil
1394         buffer-read-only nil)
1395   (erase-buffer)
1396   (insert-file-contents filename)
1397   (br-scan-mode)
1398   (setq buffer-read-only t))
1399
1400 (defvar br-lang-prefix nil
1401  "Prefix string that starts language-specific symbol names.")
1402
1403 (defvar br-children-htable nil
1404   "Htable whose elements are of the form: (LIST-OF-CHILD-CLASSES . CLASS-NAME).
1405 Used to traverse class inheritance graph.  `br-build-children-htable' builds
1406 this list.  Value is language-specific.")
1407 (defvar br-parents-htable nil
1408   "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
1409 Used to traverse class inheritance graph.  `br-build-parents-htable' builds
1410 this list.  Value is language-specific.")
1411 (defvar br-paths-htable nil
1412   "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . DIRECTORY).
1413 DIRECTORY gives the location of classes found in LIST-OF-CLASS-NAMES.
1414 `br-build-paths-htable' builds this list.  Value is language-specific.")
1415
1416 (defvar br-features-htable nil
1417   "Htable whose elements are of the form: (LIST-OF-CLASS-FEATURES . CLASS).
1418 `br-feature-build-htables' builds this htable.  Value is language-specific.")
1419 (defvar br-feature-paths-htable nil
1420   "Htable whose elements are of the form: (PATHNAME . PATHNAME-NUMBER).
1421 PATHNAME-NUMBER is an index stored in `br-features-htable' used to look up
1422 the file of definition for individual class features.
1423 `br-feature-build-htables' builds this htable.  Value is language-specific.")
1424
1425 (defvar br-lib-parents-htable nil
1426   "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
1427 Only classes from stable software libraries are used to build the list.
1428 Value is language-specific.")
1429 (defvar br-lib-paths-htable nil
1430   "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . DIRECTORY).
1431 DIRECTORY gives the location of classes found in LIST-OF-CLASS-NAMES.
1432 Only classes from stable software libraries are used to build the list.
1433 Value is language-specific.")
1434
1435 (defvar br-sys-parents-htable nil
1436   "Htable whose elements are of the form: (LIST-OF-PARENT-CLASSES . CLASS-NAME).
1437 Only classes from systems that are likely to change are used to build the
1438 list.  Value is language-specific.")
1439 (defvar br-sys-paths-htable nil
1440   "Htable whose elements are of the form: (LIST-OF-CLASS-NAMES . DIRECTORY).
1441 DIRECTORY gives the location of classes found in LIST-OF-CLASS-NAMES.
1442 Only classes from systems that are likely to change are used to build the
1443 list.  Value is language-specific.")
1444
1445 (defvar br-file-dir-regexp "\\`[^.~#]\\(.*[^.~#]\\)?\\'"
1446   "Regexp that matches only to files and directories that the OO-Browser should scan.
1447 Others are ignored.")
1448
1449 (defvar br-src-file-regexp nil
1450   "Regular expression matching a unique part of source file names and no others.")
1451
1452 (defvar br-narrow-view-to-class nil
1453  "Non-nil means narrow buffer to just the matching class definition when displayed.
1454 Don't set this, use the language specific variable instead.")
1455
1456 (provide 'br-lib)