Mercurial > hg > xemacs-beta
comparison lisp/oobr/br.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.el | |
| 4 ;; SUMMARY: Browse object-oriented code. | |
| 5 ;; USAGE: GNU Emacs Lisp Library | |
| 6 ;; KEYWORDS: matching, oop, tools | |
| 7 ;; | |
| 8 ;; AUTHOR: Bob Weiner | |
| 9 ;; ORG: Motorola Inc. | |
| 10 ;; | |
| 11 ;; ORIG-DATE: 12-Dec-89 | |
| 12 ;; LAST-MOD: 21-Sep-95 at 12:39:17 by Bob Weiner | |
| 13 ;; | |
| 14 ;; Copyright (C) 1989-1995 Free Software Foundation, Inc. | |
| 15 ;; See the file BR-COPY for license information. | |
| 16 ;; | |
| 17 ;; This file is part of the OO-Browser. | |
| 18 ;; | |
| 19 ;; DESCRIPTION: | |
| 20 ;; DESCRIP-END. | |
| 21 | |
| 22 ;;; ************************************************************************ | |
| 23 ;;; Other required Elisp libraries | |
| 24 ;;; ************************************************************************ | |
| 25 | |
| 26 (require 'br-lib) | |
| 27 | |
| 28 ;;; ************************************************************************ | |
| 29 ;;; Public variables | |
| 30 ;;; ************************************************************************ | |
| 31 | |
| 32 (defvar br-c-tags-flag t | |
| 33 "*Non-nil means add C constructs when building C-based language Environments.") | |
| 34 | |
| 35 (defvar br-directory nil | |
| 36 "Directory in which OO-Browser executable and help files are kept.") | |
| 37 | |
| 38 (defconst br-feature-signature-regexp "[:|,]" | |
| 39 "Regular expression that matches a feature signature but not a class name.") | |
| 40 | |
| 41 (defvar br-inherited-features-flag t | |
| 42 "*If non-nil (the default), feature/element listings include all inherited features. | |
| 43 If nil, only those features lexically included within a class are shown.") | |
| 44 | |
| 45 (defvar br-inhibit-version nil | |
| 46 "*Personal setting which if non-nil, skips version/credit information upon startup. | |
| 47 The default should be left as nil, since new users may find this helpful.") | |
| 48 | |
| 49 (defvar br-invert-ancestors nil | |
| 50 "*Personal setting which if non-nil makes ancestors appear as do other inheritance listings. | |
| 51 That is, parents appear above children, rather than the default, which is the | |
| 52 reverse.") | |
| 53 | |
| 54 (defvar br-keep-viewed-classes nil | |
| 55 "*Personal setting which if non-nil means leave all viewed classes around for later selection. | |
| 56 Non-nil deletes last viewed class when a new one is displayed. Note this | |
| 57 does not affect classes displayed for editing, all such classes are left | |
| 58 around.") | |
| 59 | |
| 60 (defconst br-min-width-window 25 | |
| 61 "*Minimum width of a browser class list window. | |
| 62 This together with the frame width determines the number of such windows.") | |
| 63 | |
| 64 ;; -f treats upper and lower case the same in sorting, also makes 'a' sort | |
| 65 ;; list before '[a]', so default classes appear at the end of the list, | |
| 66 ;; typically. | |
| 67 ;; -u leaves only unique elements in the sorted list | |
| 68 (defvar br-sort-options "-fu" | |
| 69 "*String of options to send to the operating system `sort' command. | |
| 70 Use nil for none. This is used by the OO-Browser (br-order) command only | |
| 71 under Emacs 18.") | |
| 72 | |
| 73 ;;; ************************************************************************ | |
| 74 ;;; Public macros | |
| 75 ;;; ************************************************************************ | |
| 76 | |
| 77 (if (fboundp 'window-highest-p) | |
| 78 (defun br-non-listing-window-p () | |
| 79 "Is the selected window a non-OO-Browser listing window?" | |
| 80 ;; Top of window is not at top of frame. | |
| 81 (not (window-highest-p (selected-window)))) | |
| 82 (defun br-non-listing-window-p () | |
| 83 "Is the selected window a non-OO-Browser listing window?" | |
| 84 ;; Top of window is not at top of frame. | |
| 85 (/= (nth 1 (window-edges)) br-top-of-frame))) | |
| 86 | |
| 87 (if (fboundp 'window-highest-p) | |
| 88 (defun br-listing-window-p () | |
| 89 "Is the selected window an OO-Browser listing window?" | |
| 90 (window-highest-p (selected-window))) | |
| 91 (defun br-listing-window-p () | |
| 92 "Is the selected window an OO-Browser listing window?" | |
| 93 ;; Top of window is at top of frame. | |
| 94 (= (nth 1 (window-edges)) br-top-of-frame))) | |
| 95 | |
| 96 ;;; ************************************************************************ | |
| 97 ;;; Public functions | |
| 98 ;;; ************************************************************************ | |
| 99 | |
| 100 (defun br-browse () | |
| 101 "Internally invoke the OO-Browser, for browsing class hierarchies. | |
| 102 Use \\[br-help] and \\[br-help-ms] for help on browser usage." | |
| 103 (interactive) | |
| 104 ;; If not already in the browser, save window config. | |
| 105 (if (br-in-browser) | |
| 106 nil | |
| 107 (setq *br-prev-wconfig* (current-window-configuration) | |
| 108 br-in-browser (selected-frame)) | |
| 109 ;; If were previously in the browser, restore its saved window config, | |
| 110 ;; otherwise, set up from scratch. | |
| 111 (if *br-save-wconfig* | |
| 112 (set-window-configuration *br-save-wconfig*) | |
| 113 (br-window-setup) | |
| 114 (if br-inhibit-version | |
| 115 (br-top-classes t) | |
| 116 (br-version) | |
| 117 (message "Press {h} for for help.") | |
| 118 ;; Display all classes. | |
| 119 (br-top-classes t) | |
| 120 (message "Press {h} for for help.") | |
| 121 ;; Wait for 60 seconds or until a single key sequence is given. | |
| 122 (sit-for 60) | |
| 123 (message "")) | |
| 124 (br-help)) | |
| 125 (run-hooks 'br-mode-hook | |
| 126 (intern (concat "br-" br-lang-prefix "mode-hook"))))) | |
| 127 | |
| 128 ;;;###autoload | |
| 129 (defun br-add-class-file (&optional class-path lib-table-p save-file) | |
| 130 "Add a file of classes to the current Environment. | |
| 131 Interactively or when optional CLASS-PATH is nil, CLASS-PATH defaults to the | |
| 132 current buffer file pathname. If optional LIB-TABLE-P is non-nil, add to | |
| 133 Library Environment, otherwise add to System Environment. If optional | |
| 134 SAVE-FILE is t, the Environment is then stored to the filename given by | |
| 135 'br-env-file'. If SAVE-FILE is non-nil and not t, its string value is used | |
| 136 as the file to which to save the Environment." | |
| 137 (interactive | |
| 138 (list (read-file-name (concat "Class file name to add" | |
| 139 (if buffer-file-name | |
| 140 (concat " (default \"" | |
| 141 (file-name-nondirectory | |
| 142 buffer-file-name) | |
| 143 "\")")) | |
| 144 ": ") | |
| 145 nil buffer-file-name t) | |
| 146 (y-or-n-p "Add to Library, rather than System tables? ") | |
| 147 (y-or-n-p | |
| 148 (concat "Save tables after addition to " br-env-file "? ")))) | |
| 149 (or class-path (setq class-path buffer-file-name)) | |
| 150 (if (not (if class-path (file-readable-p class-path))) | |
| 151 (error "(br-add-class-file): %s is not readable" class-path)) | |
| 152 (let* ((paths-parents-cons | |
| 153 (let ((br-view-file-function 'br-insert-file-contents)) | |
| 154 (br-get-classes-from-source class-path))) | |
| 155 (classes (car paths-parents-cons)) | |
| 156 (parents (cdr paths-parents-cons)) | |
| 157 (paths-key class-path) | |
| 158 (path-htable (br-get-htable (if lib-table-p "lib-paths" "sys-paths"))) | |
| 159 (par-htable (br-get-htable | |
| 160 (if lib-table-p "lib-parents" "sys-parents"))) | |
| 161 (child-htable (br-get-children-htable))) | |
| 162 (mapcar | |
| 163 (function | |
| 164 (lambda (class) | |
| 165 (br-add-to-paths-htable class paths-key path-htable))) | |
| 166 classes) | |
| 167 (mapcar | |
| 168 (function | |
| 169 (lambda (parent-cons) | |
| 170 (hash-add (car parent-cons) (cdr parent-cons) par-htable))) | |
| 171 parents) | |
| 172 (br-env-set-htables) | |
| 173 (let ((child) (par-list) children) | |
| 174 (mapcar | |
| 175 (function | |
| 176 (lambda (parent-cons) | |
| 177 (setq child (cdr parent-cons) | |
| 178 par-list (car parent-cons)) | |
| 179 (mapcar | |
| 180 (function | |
| 181 (lambda (parent) | |
| 182 (setq children (hash-get parent child-htable)) | |
| 183 (or (br-member child children) | |
| 184 (hash-add (cons child children) parent child-htable)))) | |
| 185 par-list))) | |
| 186 parents))) | |
| 187 (cond ((eq save-file nil)) | |
| 188 ((eq save-file t) (br-env-save)) | |
| 189 ((br-env-save save-file)))) | |
| 190 | |
| 191 (defun br-ancestors (&optional arg features-flag) | |
| 192 "Display ancestor tree whose root is the current class. | |
| 193 With optional prefix ARG, display all ancestor trees whose roots are in the | |
| 194 current listing. If ARG = -1 or 'br-invert-ancestors' is t, the current | |
| 195 class ancestry tree is inverted. That is, it shows branches going down | |
| 196 towards the root class, so that parents appear above children. If ARG < -1 or | |
| 197 'br-invert-ancestors' is t and ARG > 1, then the ancestry trees of all | |
| 198 classes in the current listing are inverted. | |
| 199 | |
| 200 Optional second argument, FEATURES-FLAG non-nil means display features under | |
| 201 each ancestor class." | |
| 202 (interactive "p") | |
| 203 (or arg (setq arg 1)) | |
| 204 (if br-invert-ancestors (setq arg (- arg))) | |
| 205 (let* ((class-list | |
| 206 (if (and (/= arg 1) (/= arg -1)) | |
| 207 (br-this-level-classes) | |
| 208 (list (br-find-class-name)))) | |
| 209 (parents (delq nil (mapcar (function | |
| 210 (lambda (c) (br-get-parents c))) | |
| 211 class-list)))) | |
| 212 (cond ((or parents | |
| 213 (and features-flag | |
| 214 (if (/= 1 (length class-list)) | |
| 215 t ;; Assume some class will have features. | |
| 216 ;; This class must have features. | |
| 217 (br-list-features (car class-list))))) | |
| 218 (if (and (/= arg 1) (/= arg -1)) | |
| 219 (message "Computing %s..." | |
| 220 (if features-flag "features" "ancestors"))) | |
| 221 (if features-flag | |
| 222 (progn | |
| 223 (br-add-level-hist) | |
| 224 (br-next-buffer)) | |
| 225 (let ((child-level (br-buffer-level))) | |
| 226 (br-add-level-hist) | |
| 227 (br-next-listing-window -1) | |
| 228 (br-next-buffer (concat "p" child-level)))) | |
| 229 (let (buffer-read-only) | |
| 230 (cond ((>= arg 0) | |
| 231 (br-ancestor-trees-inverted class-list)) | |
| 232 (t | |
| 233 (br-ancestor-trees class-list)))) | |
| 234 (goto-char (point-min)) | |
| 235 (if (and (/= arg 1) (/= arg -1)) | |
| 236 (message "Computing %s...Done" | |
| 237 (if features-flag "features" "ancestors"))) | |
| 238 t) | |
| 239 (t | |
| 240 (message "No %s." (if features-flag "features" "ancestors")) | |
| 241 (beep))))) | |
| 242 | |
| 243 (defun br-at (&optional arg) | |
| 244 "Display current class location in the inheritance graph. | |
| 245 The class is displayed among both its ancestors and descendants. | |
| 246 With optional prefix ARG, display location for all classes in the current | |
| 247 listing." | |
| 248 (interactive "P") | |
| 249 (let* ((parent) | |
| 250 (parent-list | |
| 251 (if arg | |
| 252 (br-this-level-classes) | |
| 253 (list (setq parent (br-find-class-name)))))) | |
| 254 (if arg | |
| 255 (message "Computing class locations...") | |
| 256 (br-narrow-to-class)) | |
| 257 (br-add-level-hist) | |
| 258 (br-next-buffer) | |
| 259 (let (buffer-read-only) | |
| 260 (br-descendant-trees (br-ancestor-roots parent-list)) | |
| 261 (goto-char (point-min)) | |
| 262 (if arg | |
| 263 (message "Computing class locations...Done") | |
| 264 (re-search-forward (concat "\\(^\\|[ \t]+\\)" parent "$")) | |
| 265 (goto-char (match-end 1)) | |
| 266 (recenter '(4)))))) | |
| 267 | |
| 268 (defun br-categories (&optional arg) | |
| 269 "Display categories directly associated with the current class. | |
| 270 This does not include any categories which the class inherits. | |
| 271 With optional prefix ARG, display categories of all classes in the current | |
| 272 listing." | |
| 273 (interactive "P") | |
| 274 (let ((has-categories) | |
| 275 class-list categories class-and-categories) | |
| 276 (setq class-list (cond (arg | |
| 277 (message "Computing class categories...") | |
| 278 (br-this-level-classes)) | |
| 279 (t | |
| 280 (list (br-find-class-name)))) | |
| 281 categories | |
| 282 (delq nil (mapcar | |
| 283 (function | |
| 284 (lambda (class) | |
| 285 (setq class-and-categories (br-list-categories class) | |
| 286 has-categories (or has-categories | |
| 287 class-and-categories)) | |
| 288 (cons class class-and-categories))) | |
| 289 class-list))) | |
| 290 (cond ((not class-list) | |
| 291 (message "(OO-Browser): Apply 'br-categories' to a class.") (beep)) | |
| 292 ((not has-categories) | |
| 293 (message "No class categories.") (beep)) | |
| 294 (t | |
| 295 (br-add-level-hist) | |
| 296 (br-next-buffer nil) | |
| 297 (let (buffer-read-only done-set class) | |
| 298 (mapcar | |
| 299 (function | |
| 300 (lambda (class-and-categories) | |
| 301 (setq class (car class-and-categories)) | |
| 302 (if (not (br-set-cons done-set class)) | |
| 303 (insert class " ...\n") | |
| 304 ;; Class successfully added to set, so it has not been | |
| 305 ;; listed before. | |
| 306 (insert class "\n") | |
| 307 (br-insert-features (cdr class-and-categories) 2)))) | |
| 308 categories)) | |
| 309 (message "Computing class categories...Done") | |
| 310 (goto-char (point-min)) | |
| 311 t)))) | |
| 312 | |
| 313 (defun br-children (&optional arg) | |
| 314 "Display children of current class. | |
| 315 With optional prefix ARG, display children of all the classes in the current | |
| 316 listing." | |
| 317 (interactive "P") | |
| 318 (let ((class-list (cond (arg | |
| 319 (message "Computing children...") | |
| 320 (br-this-level-classes)) | |
| 321 (t | |
| 322 (list (br-find-class-name))))) | |
| 323 (has-children) | |
| 324 children children-list) | |
| 325 (setq children-list (delq nil (mapcar | |
| 326 (function | |
| 327 (lambda (parent) | |
| 328 (setq children | |
| 329 (br-get-children parent) | |
| 330 has-children | |
| 331 (or has-children children)) | |
| 332 (cons parent children))) | |
| 333 class-list))) | |
| 334 (cond ((not children-list) | |
| 335 (message "(OO-Browser): Apply 'br-children' to a class.") | |
| 336 (beep)) | |
| 337 ((not has-children) | |
| 338 (message "No children.") (beep)) | |
| 339 (t | |
| 340 (br-add-level-hist) | |
| 341 (br-next-buffer nil) | |
| 342 (let (buffer-read-only done-set parent) | |
| 343 (mapcar | |
| 344 (function | |
| 345 (lambda (parent-children-cons) | |
| 346 (setq parent (car parent-children-cons)) | |
| 347 (if (not (br-set-cons done-set parent)) | |
| 348 (insert parent " ...\n") | |
| 349 ;; Class successfully added to set, so it has not been | |
| 350 ;; listed before. | |
| 351 (insert parent "\n") | |
| 352 (br-insert-classes (cdr parent-children-cons) 2)))) | |
| 353 children-list)) | |
| 354 (if arg (message "Computing children...Done")) | |
| 355 (goto-char (point-min)) | |
| 356 t)))) | |
| 357 | |
| 358 (defun br-class-stats (&optional prompt) | |
| 359 "Display statistics summary for current class. | |
| 360 Optional prefix arg PROMPT means prompt for class name." | |
| 361 (interactive "P") | |
| 362 (let ((class-name (if prompt (br-complete-class-name) (br-find-class-name)))) | |
| 363 (if class-name | |
| 364 (message "Class %s: Parents: %d; Children: %d" | |
| 365 class-name (length (br-get-parents class-name)) | |
| 366 (length (br-get-children class-name))) | |
| 367 (error "No class name at point.")))) | |
| 368 | |
| 369 (defun br-cmd-help (key &optional full) | |
| 370 "Show first line of doc for OO-Browser KEY in minibuffer. | |
| 371 With optional FULL, display full documentation for command." | |
| 372 (interactive "kOO-Browser key binding: \nP") | |
| 373 (let* ((cmd (let ((cmd (if (eq major-mode 'br-mode) | |
| 374 (lookup-key br-mode-map key) | |
| 375 (key-binding key)))) | |
| 376 (if (not (integerp cmd)) cmd))) | |
| 377 (doc (and cmd (documentation cmd))) | |
| 378 (end-line)) | |
| 379 (if doc | |
| 380 (or full | |
| 381 (setq end-line (string-match "[\n]" doc) | |
| 382 doc (substitute-command-keys (substring doc 0 end-line)))) | |
| 383 (setq doc (format "No documentation for {%s} %s" key (or cmd "")))) | |
| 384 (if (and cmd doc) | |
| 385 (if full | |
| 386 (progn (br-to-view-window) | |
| 387 (other-window -1) | |
| 388 (describe-function cmd)) | |
| 389 (message doc))))) | |
| 390 | |
| 391 (defun br-count () | |
| 392 "Count number of entries visible in current listing buffer. | |
| 393 Print text result in minibuffer when called interactively." | |
| 394 (interactive) | |
| 395 (let ((cnt (count-lines (point-min) (point-max)))) | |
| 396 (if (interactive-p) | |
| 397 (message "%s contains %d entries." (buffer-name) cnt) | |
| 398 cnt))) | |
| 399 | |
| 400 (defun br-copyright () | |
| 401 "Display browser copyright information in viewer window." | |
| 402 (interactive) | |
| 403 (br-file-to-viewer "BR-COPY")) | |
| 404 | |
| 405 (defun br-delete (&optional prompt) | |
| 406 "Delete class from current Environment. | |
| 407 Does not alter descendency relations. | |
| 408 Optional prefix arg PROMPT means prompt for class name." | |
| 409 (interactive "P") | |
| 410 (let ((class (if prompt (br-complete-class-name) (br-find-class-name)))) | |
| 411 (and class | |
| 412 (if (interactive-p) | |
| 413 (y-or-n-p (concat "Delete class " class " from Environment? ")) | |
| 414 t) | |
| 415 (progn (br-real-delete-class class) | |
| 416 ;; Delete class name at point in listing window | |
| 417 (or prompt (let (buffer-read-only) | |
| 418 (progn (beginning-of-line) | |
| 419 (delete-region | |
| 420 (point) (progn (forward-line 1) | |
| 421 (point)))))) | |
| 422 (message "Class " class " deleted."))))) | |
| 423 | |
| 424 (defun br-descendants (&optional arg) | |
| 425 "Display descendant tree whose root is the current class. | |
| 426 With optional prefix ARG, display all descendant trees whose roots are | |
| 427 the classes in the current listing." | |
| 428 (interactive "P") | |
| 429 (let ((parent-list | |
| 430 (if arg | |
| 431 (br-this-level-classes) | |
| 432 (list (br-find-class-name))))) | |
| 433 (cond ((delq nil (mapcar | |
| 434 (function (lambda (parent) | |
| 435 (br-get-children parent))) | |
| 436 parent-list)) | |
| 437 (if arg (message "Computing descendants...")) | |
| 438 (br-add-level-hist) | |
| 439 (br-next-buffer) | |
| 440 (let (buffer-read-only) | |
| 441 (br-descendant-trees parent-list)) | |
| 442 (goto-char (point-min)) | |
| 443 (if arg (message "Computing descendants...Done")) | |
| 444 t) | |
| 445 (t | |
| 446 (message "No descendants.") (beep))))) | |
| 447 | |
| 448 (defun br-edit-entry (&optional prompt) | |
| 449 "Edits source for any browser listing entry, such as a class or a feature. | |
| 450 Optional prefix arg PROMPT means prompt for entry name." | |
| 451 (interactive "P") | |
| 452 (let ((entry) (sig)) | |
| 453 (if prompt | |
| 454 (cond ((and (setq entry (br-complete-entry)) | |
| 455 (string-match br-feature-signature-regexp entry)) | |
| 456 (if (setq sig (car (br-feature-signature-and-file entry))) | |
| 457 (br-feature nil nil sig) | |
| 458 (error "(br-feature-signature-and-file): Couldn't find match for: '%s'" entry))) | |
| 459 (entry ;; class name | |
| 460 (br-edit nil entry)) | |
| 461 (t (error "(br-complete-entry): Exited without selecting a match"))) | |
| 462 (cond ((br-find-feature-entry) | |
| 463 (br-feature)) | |
| 464 ((and (setq entry (br-find-class-name)) | |
| 465 (br-class-in-table-p entry)) | |
| 466 (br-edit nil entry)) | |
| 467 (t (error "(OO-Browser): No entry for current line in current Environment")))))) | |
| 468 | |
| 469 (defun br-edit (&optional prompt class) | |
| 470 "Edit a class in the viewer window. | |
| 471 Select viewer window. With optional prefix arg PROMPT, prompt for class | |
| 472 name. Optional CLASS is the one to edit." | |
| 473 (interactive "P") | |
| 474 (or br-editor-cmd | |
| 475 (br-in-view-window-p) | |
| 476 (setq *br-prev-listing-window* (selected-window))) | |
| 477 (br-view prompt t class)) | |
| 478 | |
| 479 (defun br-edit-ext (editor-cmd file) | |
| 480 "Invoke a non-standard EDITOR-CMD on FILE. | |
| 481 See also 'br-editor-cmd'." | |
| 482 (interactive "fFile to edit: ") | |
| 483 (or editor-cmd (setq editor-cmd br-editor-cmd)) | |
| 484 (if (not (stringp editor-cmd)) ;; must be a Lisp function that takes a | |
| 485 ;; single, file arg | |
| 486 (funcall editor-cmd file) | |
| 487 (setq delete-exited-processes t) | |
| 488 (let ((proc) | |
| 489 (name (concat br-ed-name br-ed-num)) | |
| 490 ) | |
| 491 (setq br-ed-num (1+ br-ed-num) | |
| 492 proc (br-edit-ext-start editor-cmd name file)) | |
| 493 (if proc | |
| 494 (process-kill-without-query proc) | |
| 495 (beep) | |
| 496 (message "(OO-Browser): Could not start external edit process: %s" | |
| 497 editor-cmd))))) | |
| 498 | |
| 499 (defun br-editor-kill () | |
| 500 "Kill all current external editor sub-processes." | |
| 501 (interactive) | |
| 502 (if (br-kill-process-group br-ed-name br-ed-num "external editors") | |
| 503 (setq br-ed-num 0))) | |
| 504 | |
| 505 (defun br-entry-info () | |
| 506 "Display attributes of the current entry in the viewer window." | |
| 507 (interactive) | |
| 508 (if (fboundp 'br-insert-class-info) | |
| 509 (let ((class-name (br-find-class-name))) | |
| 510 (if class-name | |
| 511 (progn | |
| 512 (message "Building '%s' class info..." class-name) | |
| 513 ; (sit-for 2) ; Why should we pause here? | |
| 514 (br-store-class-info class-name) | |
| 515 (message "Building '%s' class info...Done" class-name) | |
| 516 (br-funcall-in-view-window | |
| 517 (concat br-buffer-prefix-info "Info") | |
| 518 'br-insert-class-info)) | |
| 519 (error "Move point to a class name line."))) | |
| 520 (beep) | |
| 521 (message "No class information function for this language."))) | |
| 522 | |
| 523 (defun br-exit-level (arg) | |
| 524 "Return to prefix ARGth previous inheritance level listing. | |
| 525 The command is ignored with ARG < 1." | |
| 526 (interactive "p") | |
| 527 (setq arg (or arg 1)) | |
| 528 (let ((prev-wind-buf-line)) | |
| 529 (if (null *br-level-hist*) | |
| 530 (and (> arg 0) | |
| 531 (message "No previous level to which to exit.") | |
| 532 (beep)) | |
| 533 (while (and (> arg 0) *br-level-hist*) | |
| 534 (br-next-buffer (br-listing-window-num) br-buffer-prefix-blank) | |
| 535 (setq prev-wind-buf-line (car *br-level-hist*) | |
| 536 *br-level-hist* (cdr *br-level-hist*) | |
| 537 arg (1- arg)) | |
| 538 (select-window (car prev-wind-buf-line)) | |
| 539 (switch-to-buffer (car (cdr prev-wind-buf-line)))) | |
| 540 (widen) | |
| 541 ;; Position window lines exactly as before. | |
| 542 (recenter (car (cdr (cdr prev-wind-buf-line))))))) | |
| 543 | |
| 544 (defun br-feature (&optional arg view-only ftr-sig) | |
| 545 "Edit a feature in the viewer window. Select viewer window. | |
| 546 With optional prefix ARG, prompt for feature name. | |
| 547 Optional VIEW-ONLY non-nil means view rather than edit feature. | |
| 548 Optional FTR-SIG is signature of feature to edit." | |
| 549 (interactive "P") | |
| 550 (or ftr-sig | |
| 551 (setq ftr-sig (if arg | |
| 552 (br-feature-complete 'must-match) | |
| 553 ;; Get current feature signature | |
| 554 (br-feature-get-signature)))) | |
| 555 (if (null ftr-sig) | |
| 556 (error "(br-feature): No definition for this entry") | |
| 557 (br-to-view-window) | |
| 558 (if (br-feature-found-p (br-feature-file ftr-sig) ftr-sig) | |
| 559 (if view-only | |
| 560 (progn (setq buffer-read-only t) | |
| 561 (br-to-from-viewer)) | |
| 562 (if (file-writable-p (buffer-file-name)) | |
| 563 (setq buffer-read-only nil))) | |
| 564 ;; Feature not found. Return to original window and signal an error. | |
| 565 (br-to-from-viewer) | |
| 566 (error "(br-feature): Can't find definition of: '%s'" ftr-sig)))) | |
| 567 | |
| 568 (defun br-features (arg) | |
| 569 "Display features/elements of the current class (prefix ARG = 1) or of the current listing if ARG is other than 0 or 1. | |
| 570 | |
| 571 With ARG = 0, the value of the variable, 'br-inherited-features-flag', is | |
| 572 toggled and no other action is taken. | |
| 573 | |
| 574 If 'br-inherited-features-flag' is t, all features of each class are shown. | |
| 575 If nil, only lexically included features are shown and if the features of a | |
| 576 single class are requested and none are defined, the class definition is | |
| 577 displayed so that its feature declarations may be browsed." | |
| 578 (interactive "p") | |
| 579 (cond ((and (integerp arg) (= arg 0)) | |
| 580 (setq br-inherited-features-flag | |
| 581 (not br-inherited-features-flag)) | |
| 582 (message "Inherited features/elements will %sbe shown." | |
| 583 (if br-inherited-features-flag "" "not "))) | |
| 584 (br-inherited-features-flag | |
| 585 (br-inherited-features arg)) | |
| 586 (t (br-lexical-features arg)))) | |
| 587 | |
| 588 (defun br-find (element) | |
| 589 "Interactively complete class or ELEMENT name and jump to its definition. | |
| 590 Return ELEMENT or signal an error." | |
| 591 (interactive (list (br-complete-entry))) | |
| 592 (if (and element | |
| 593 (progn | |
| 594 (if (not (br-in-view-window-p)) (br-to-from-viewer)) | |
| 595 (if (string-match br-feature-signature-regexp element) | |
| 596 (br-find-feature element) | |
| 597 (br-find-class element)))) | |
| 598 element | |
| 599 (error "(OO-Browser): '%s' definition not found." element))) | |
| 600 | |
| 601 (defun br-help (&optional file) | |
| 602 "Display browser operation help information in viewer window." | |
| 603 (interactive) | |
| 604 (or file (setq file "br-help")) | |
| 605 (br-file-to-viewer file) | |
| 606 (save-window-excursion | |
| 607 (br-to-view-window) | |
| 608 (br-mode) | |
| 609 (use-local-map nil)) | |
| 610 (message "")) | |
| 611 | |
| 612 (defun br-help-ms () | |
| 613 "Display browser mouse usage help information in viewer window." | |
| 614 (interactive) | |
| 615 (br-help "br-help-ms")) | |
| 616 | |
| 617 (defun br-implementors (&optional arg) | |
| 618 "Display hierarchy of classes that define current element. | |
| 619 Ignore inherited elements. With optional prefix ARG, display implementors of | |
| 620 all elements in the current listing." | |
| 621 (interactive "P") | |
| 622 (let | |
| 623 ((child-level (br-buffer-level)) | |
| 624 (ftr-list (if arg (br-set-of-strings | |
| 625 (sort (br-this-level-features) 'string-lessp)) | |
| 626 ;; Need this check to avoid trying to find implementors of | |
| 627 ;; a class which happens to have an attached element tag, | |
| 628 ;; e.g. in an implementors listing buffer. | |
| 629 (save-excursion | |
| 630 (beginning-of-line) | |
| 631 (skip-chars-forward " \t") | |
| 632 (if (looking-at br-feature-entry) | |
| 633 (list (br-find-feature-entry))))))) | |
| 634 (if (or (null ftr-list) (null (car ftr-list))) | |
| 635 (error | |
| 636 "(OO-Browser): 'br-implementors' must be applied to a feature.") | |
| 637 (message "Computing implementors...") | |
| 638 (br-add-level-hist) | |
| 639 (br-next-listing-window -1) | |
| 640 (br-next-buffer (concat "p" child-level)) | |
| 641 (let ((buffer-read-only) (implementor-tags) (classes) | |
| 642 start) | |
| 643 (widen) | |
| 644 (erase-buffer) | |
| 645 (mapcar (function | |
| 646 (lambda (ftr-entry) | |
| 647 (setq implementor-tags | |
| 648 (sort | |
| 649 (br-feature-implementors | |
| 650 (br-feature-name ftr-entry)) | |
| 651 'string-lessp) | |
| 652 classes (mapcar 'br-feature-tag-class | |
| 653 implementor-tags)) | |
| 654 (insert ftr-entry "\n") | |
| 655 (setq start (point)) | |
| 656 (br-insert-classes classes 4) | |
| 657 (save-excursion | |
| 658 (goto-char start) | |
| 659 (br-feature-put-signatures implementor-tags)))) | |
| 660 ftr-list)) | |
| 661 (goto-char 1) | |
| 662 (message "Computing implementors...Done")))) | |
| 663 | |
| 664 (defun br-inherited-features (arg) | |
| 665 "Display class features, including those from ancestors. | |
| 666 With optional prefix ARG, display features of all classes in the current | |
| 667 listing." | |
| 668 (interactive "p") | |
| 669 (let ((br-ancestor-function | |
| 670 (function | |
| 671 (lambda (class repeated-class indent) | |
| 672 (if repeated-class | |
| 673 nil | |
| 674 (br-insert-features (br-list-features class indent) indent)))))) | |
| 675 (br-ancestors arg t))) | |
| 676 | |
| 677 (defun br-kill () | |
| 678 "Kill buffer in viewer window and redisplay help text." | |
| 679 (interactive) | |
| 680 (br-do-in-view-window '(progn (kill-buffer nil) (br-help)))) | |
| 681 | |
| 682 (defun br-lexical-features (arg) | |
| 683 "Display class features lexically defined within current class. | |
| 684 With numeric prefix ARG, display features of all classes in the current | |
| 685 listing. | |
| 686 | |
| 687 If the features of a single class are requested and there are no feature | |
| 688 definitions for the class, display the class definition so that its feature | |
| 689 declarations may be browsed." | |
| 690 (interactive "p") | |
| 691 (let ((has-features) | |
| 692 class-list features class-and-features) | |
| 693 (setq class-list (cond ((and (integerp arg) (/= arg 1)) | |
| 694 (message "Computing class features...") | |
| 695 (br-this-level-classes)) | |
| 696 (t | |
| 697 (list (br-find-class-name)))) | |
| 698 features | |
| 699 (delq nil (mapcar | |
| 700 (function | |
| 701 (lambda (class) | |
| 702 (setq class-and-features (br-list-features class) | |
| 703 has-features (or has-features | |
| 704 class-and-features)) | |
| 705 (cons class class-and-features))) | |
| 706 class-list))) | |
| 707 (cond ((not class-list) | |
| 708 (beep) | |
| 709 (message "(OO-Browser): Apply 'br-features' to a class.")) | |
| 710 ((not has-features) | |
| 711 (if (and (= (length class-list) 1) | |
| 712 (br-class-path (car class-list))) | |
| 713 (if (br-view nil nil (car class-list)) | |
| 714 (message | |
| 715 "No feature definitions, browse declarations instead.")) | |
| 716 (message "No class features.") (beep))) | |
| 717 (t | |
| 718 (br-add-level-hist) | |
| 719 (br-next-buffer nil) | |
| 720 (let (buffer-read-only done-set class) | |
| 721 (mapcar | |
| 722 (function | |
| 723 (lambda (class-and-features) | |
| 724 (setq class (car class-and-features)) | |
| 725 (if (not (br-set-cons done-set class)) | |
| 726 (insert class " ...\n") | |
| 727 ;; Class successfully added to set, so it has not been | |
| 728 ;; listed before. | |
| 729 (insert class "\n") | |
| 730 (br-insert-features (cdr class-and-features) 2)))) | |
| 731 features) | |
| 732 (message "Computing class features...Done") | |
| 733 (goto-char (point-min))))))) | |
| 734 | |
| 735 (defun br-lib-rebuild () | |
| 736 "Rescan Library components of the current Environment." | |
| 737 (interactive) | |
| 738 (if (call-interactively 'br-build-lib-htable) | |
| 739 (br-top-classes t))) | |
| 740 | |
| 741 (defun br-lib-top-classes (&optional arg) | |
| 742 "Display list of top level Library classes. | |
| 743 With prefix ARG, display all Library classes." | |
| 744 (interactive "P") | |
| 745 (and (or (not (interactive-p)) | |
| 746 (br-in-top-buffer-p) | |
| 747 (y-or-n-p "Exit to top-level class listing buffer? ")) | |
| 748 (cond (arg | |
| 749 (br-show-top-classes | |
| 750 (function (lambda () (br-all-classes "lib"))) | |
| 751 'uniq) | |
| 752 (message "Listing of all Library classes")) | |
| 753 (t | |
| 754 (br-show-top-classes 'br-get-lib-top-classes 'uniq) | |
| 755 (message "Listing of top-level Library classes"))) | |
| 756 (setq *br-level-hist* nil))) | |
| 757 | |
| 758 (defun br-match (&optional expr arg again matched) | |
| 759 "Show all class names in current Environment that contain optional EXPR. | |
| 760 Nil value of EXPR means prompt for a value. With optional prefix ARG, EXPR | |
| 761 is treated as a string. By default, it is treated as a regular expresion. | |
| 762 AGAIN non-nil shows the number of classes MATCHED from the last search, | |
| 763 allowing repeated narrowing of the search set. Empty EXPR when AGAIN is nil | |
| 764 matches to all classes in the Environment." | |
| 765 (interactive (list nil current-prefix-arg)) | |
| 766 (or expr (setq expr (read-string | |
| 767 (concat (if again (format "(%s matches) " matched)) | |
| 768 (if arg | |
| 769 "Find Environment class string matches" | |
| 770 "Find Environment class regular expression matches") | |
| 771 (if again " (RTN to end): " ": "))))) | |
| 772 (if (and again (equal expr "")) | |
| 773 nil | |
| 774 (let* ((match-expr (if arg (regexp-quote expr) expr)) | |
| 775 (classes | |
| 776 (delq nil (mapcar | |
| 777 (function | |
| 778 (lambda (cl) | |
| 779 (if (string-match match-expr cl) cl))) | |
| 780 (if again | |
| 781 (sort (br-this-level-classes) 'string-lessp) | |
| 782 (br-all-classes)))))) | |
| 783 (setq classes (br-class-list-filter classes)) | |
| 784 (if classes | |
| 785 (progn (let (buffer-read-only) | |
| 786 (br-feature-clear-signatures) | |
| 787 (erase-buffer) | |
| 788 (br-insert-classes classes 0)) | |
| 789 (goto-char (point-min)) | |
| 790 (br-match nil arg t (br-count))) | |
| 791 (beep) | |
| 792 (message "No matches for \"%s\"." expr))))) | |
| 793 | |
| 794 (defun br-match-entries (&optional expr arg again matched) | |
| 795 "Show all entries in current listing that contain optional EXPR. | |
| 796 Nil value of EXPR means prompt for a value. With optional prefix ARG, EXPR | |
| 797 is treated as a string. By default, it is treated as a regular expresion. | |
| 798 AGAIN non-nil means show the number of entries MATCHED from last search, | |
| 799 allowing repeated narrowing of the search set. Empty EXPR when AGAIN is nil | |
| 800 matches to all entries in the listing." | |
| 801 (interactive (list nil current-prefix-arg)) | |
| 802 (or expr (setq expr (read-string | |
| 803 (concat (if again (format "(%s matches) " matched)) | |
| 804 (if arg | |
| 805 "Find string matches in listing" | |
| 806 "Find regular expression matches in listing") | |
| 807 (if again " (RTN to end): " ": "))))) | |
| 808 (if (and again (equal expr "")) | |
| 809 nil | |
| 810 (let* ((match-expr (if arg (regexp-quote expr) expr)) | |
| 811 (buffer-read-only)) | |
| 812 (goto-char (point-min)) | |
| 813 (if (not (re-search-forward match-expr nil t)) | |
| 814 (progn (beep) | |
| 815 (message "No matches for \"%s\"." expr)) | |
| 816 (goto-char (point-min)) | |
| 817 (delete-non-matching-lines match-expr) | |
| 818 (goto-char (point-min)) | |
| 819 (br-match-entries nil arg t (br-count)))))) | |
| 820 | |
| 821 (defun br-next-entry (arg) | |
| 822 "Move point vertically down prefix ARG number of lines in listing buffer." | |
| 823 (interactive "p") | |
| 824 (let ((end)) | |
| 825 (setq end (= (forward-line arg) arg)) | |
| 826 (and (looking-at "^$") (forward-line -1) (setq end t)) | |
| 827 (and end (message "No next entry.") (beep)))) | |
| 828 | |
| 829 (defun br-order (arg) | |
| 830 "Order current browser listing window entries. | |
| 831 With prefix ARG other than 1 (the default), don't remove leading space from | |
| 832 entry lines before ordering. Negative ARG means order in descending Ascii | |
| 833 sequence, otherwise order in ascending sequence." | |
| 834 (interactive "p") | |
| 835 (setq arg (or arg 1)) | |
| 836 (message "Ordering entries...") | |
| 837 (let ((buffer-read-only) | |
| 838 sort-args) | |
| 839 (and (= arg 1) (progn (goto-char (point-min)) | |
| 840 (while (re-search-forward "^[ \t]+" nil t) | |
| 841 (replace-match "")))) | |
| 842 (if (string-match "^19\\." emacs-version) | |
| 843 (progn | |
| 844 ;; Emacs 19: This slower than calling an external sort but it | |
| 845 ;; maintains the element tags in a listing, allowing further browsing | |
| 846 ;; from this buffer. | |
| 847 (sort-lines (< arg 0) (point-min) (point-max)) | |
| 848 ;; Move [default] classes to the end of the sorted list. | |
| 849 (goto-char (point-min)) | |
| 850 (if (re-search-forward "^[ \t]*\\[" nil t) | |
| 851 (let (start end) | |
| 852 (beginning-of-line) | |
| 853 (setq start (point)) | |
| 854 (goto-char (point-max)) | |
| 855 (re-search-backward "^[ \t]*\\[" nil t) | |
| 856 (forward-line 1) | |
| 857 (setq end (point)) | |
| 858 (goto-char (point-max)) | |
| 859 (append-to-buffer (current-buffer) start end) | |
| 860 (delete-region start end)))) | |
| 861 ;; | |
| 862 ;; Emacs 18: We can't maintain the buffer tags, so we just use a fast | |
| 863 ;; external sort. | |
| 864 (setq sort-args (list (point-min) (point-max) "sort" t t nil) | |
| 865 sort-args (if (< arg 0) | |
| 866 (if (stringp br-sort-options) | |
| 867 (nconc sort-args (list "-r" br-sort-options)) | |
| 868 (nconc sort-args (list "-r"))) | |
| 869 (if (stringp br-sort-options) | |
| 870 (nconc sort-args (list br-sort-options)) | |
| 871 sort-args))) | |
| 872 (apply 'call-process-region sort-args))) | |
| 873 (goto-char (point-min)) | |
| 874 (message "Ordering entries...Done")) | |
| 875 | |
| 876 (defun br-parents (&optional arg) | |
| 877 "Display parents of current class. | |
| 878 With optional prefix ARG, display parents of all the classes in the current | |
| 879 listing." | |
| 880 (interactive "P") | |
| 881 (let ((class-list (cond (arg | |
| 882 (message "Computing parents...") | |
| 883 (br-this-level-classes)) | |
| 884 (t | |
| 885 (list (br-find-class-name))))) | |
| 886 (has-parents) | |
| 887 parents parents-list) | |
| 888 (setq parents-list | |
| 889 (delq nil (mapcar (function | |
| 890 (lambda (class) | |
| 891 (setq parents (br-get-parents class) | |
| 892 has-parents (or has-parents parents)) | |
| 893 (cons class parents))) | |
| 894 class-list))) | |
| 895 (cond ((not parents-list) | |
| 896 (message "(OO-Browser): Apply 'br-parents' to a class.") (beep)) | |
| 897 ((not has-parents) | |
| 898 (message "No parents.") (beep)) | |
| 899 (t | |
| 900 (let ((child-level (br-buffer-level))) | |
| 901 (br-add-level-hist) | |
| 902 (br-next-listing-window -1) | |
| 903 (br-next-buffer (concat "p" child-level))) | |
| 904 (let (buffer-read-only done-set class) | |
| 905 (mapcar | |
| 906 (function | |
| 907 (lambda (class-parents-cons) | |
| 908 (setq class (car class-parents-cons)) | |
| 909 (if (not (br-set-cons done-set class)) | |
| 910 (insert class " ...\n") | |
| 911 ;; Class successfully added to set, so it has not been | |
| 912 ;; listed before. | |
| 913 (insert class "\n") | |
| 914 (br-insert-classes (cdr class-parents-cons) 2)))) | |
| 915 parents-list)) | |
| 916 (if arg (message "Computing parents...Done")) | |
| 917 (goto-char (point-min)) | |
| 918 t)))) | |
| 919 | |
| 920 (defun br-prev-entry (arg) | |
| 921 "Move point vertically up prefix ARG number of lines in listing buffer." | |
| 922 (interactive "p") | |
| 923 (setq arg (- arg)) | |
| 924 (and (= (forward-line arg) arg) | |
| 925 (message "No previous entry.") | |
| 926 (beep))) | |
| 927 | |
| 928 (defun br-protocols (&optional arg) | |
| 929 "Display protocols to which the current class conforms. | |
| 930 This does not include any protocols which the class inherits from its | |
| 931 ancestors but it does include protocols which conform to other protocols. | |
| 932 With optional prefix ARG, display protocols of all classes in the current | |
| 933 listing." | |
| 934 (interactive "P") | |
| 935 (let ((has-protocols) | |
| 936 class-list protocols class-and-protocols) | |
| 937 (setq class-list (cond (arg | |
| 938 (message "Computing class protocols...") | |
| 939 (br-this-level-classes)) | |
| 940 (t | |
| 941 (list (br-find-class-name))))) | |
| 942 (if (and (= (length class-list) 1) | |
| 943 (br-protocol-entry-p)) | |
| 944 ;; If on a protocol entry, display its definition. | |
| 945 (br-view-protocol (car class-list)) | |
| 946 ;; Otherwise, list protocols for all elements of class-list. | |
| 947 (setq protocols | |
| 948 (delq nil (mapcar | |
| 949 (function | |
| 950 (lambda (class) | |
| 951 (setq class-and-protocols (br-list-protocols class) | |
| 952 has-protocols (or has-protocols | |
| 953 class-and-protocols)) | |
| 954 (cons class class-and-protocols))) | |
| 955 class-list))) | |
| 956 (cond ((not class-list) | |
| 957 (beep) | |
| 958 (message "(OO-Browser): Apply 'br-protocols' to a class.")) | |
| 959 ((not has-protocols) | |
| 960 (message "No class protocols.") (beep)) | |
| 961 (t | |
| 962 (br-add-level-hist) | |
| 963 (br-next-buffer nil) | |
| 964 (let (buffer-read-only done-set class) | |
| 965 (mapcar | |
| 966 (function | |
| 967 (lambda (class-and-protocols) | |
| 968 (setq class (car class-and-protocols)) | |
| 969 (if (not (br-set-cons done-set class)) | |
| 970 (insert class " ...\n") | |
| 971 ;; Class successfully added to set, so it has not been | |
| 972 ;; listed before. | |
| 973 (insert class "\n") | |
| 974 (br-insert-features (cdr class-and-protocols) 2)))) | |
| 975 protocols)) | |
| 976 (message "Computing class protocols...Done") | |
| 977 (goto-char (point-min))))))) | |
| 978 | |
| 979 (defun br-quit (&optional arg) | |
| 980 "Quit browser. | |
| 981 With optional prefix ARG, delete window configurations and listing | |
| 982 buffers associated with the browser." | |
| 983 (interactive "P") | |
| 984 (if (not (br-in-browser)) | |
| 985 (br-interrupt arg) | |
| 986 (if (null arg) | |
| 987 (setq *br-save-wconfig* (current-window-configuration)) | |
| 988 (if (featurep 'br-tree) (br-tree-kill)) | |
| 989 (br-viewer-kill) | |
| 990 ;; Too dangerous to include (br-editor-kill) here. | |
| 991 ;; The user can invoke it manually if desired. | |
| 992 ) | |
| 993 (and *br-prev-wconfig* (set-window-configuration *br-prev-wconfig*)) | |
| 994 (br-interrupt arg))) | |
| 995 | |
| 996 (defun br-refresh () | |
| 997 "Restore OO-Browser to its state upon startup." | |
| 998 (interactive) | |
| 999 (br-window-setup) | |
| 1000 (br-top-classes t) | |
| 1001 (br-help) | |
| 1002 (setq br-in-browser (selected-frame))) | |
| 1003 | |
| 1004 (defun br-report-bug () | |
| 1005 "Send a message to the OO-Browser discussion list." | |
| 1006 (interactive) | |
| 1007 (if (br-in-browser) (br-to-view-window)) | |
| 1008 (hmail:compose "oo-browser@hub.ucsb.edu" '(hypb:configuration))) | |
| 1009 | |
| 1010 (defun br-sys-rebuild () | |
| 1011 "Rescan System components of the current Environment." | |
| 1012 (interactive) | |
| 1013 (if (call-interactively 'br-build-sys-htable) | |
| 1014 (br-top-classes t))) | |
| 1015 | |
| 1016 (defun br-sys-top-classes (&optional arg) | |
| 1017 "Display list of top level System classes. | |
| 1018 With prefix ARG, display all System classes." | |
| 1019 (interactive "P") | |
| 1020 (and (or (not (interactive-p)) | |
| 1021 (br-in-top-buffer-p) | |
| 1022 (y-or-n-p "Exit to top-level class listing buffer? ")) | |
| 1023 (cond (arg | |
| 1024 (br-show-top-classes | |
| 1025 (function (lambda () (br-all-classes "sys"))) | |
| 1026 'uniq) | |
| 1027 (message "Listing of all System classes")) | |
| 1028 (t | |
| 1029 (br-show-top-classes 'br-get-sys-top-classes 'uniq) | |
| 1030 (message "Listing of top-level System classes"))) | |
| 1031 (setq *br-level-hist* nil))) | |
| 1032 | |
| 1033 ;;;###autoload | |
| 1034 (defun br-to-from-viewer () | |
| 1035 "Move point to viewer window or back to last recorded listing window." | |
| 1036 (interactive) | |
| 1037 (if (br-in-view-window-p) | |
| 1038 (progn (if *br-prev-listing-window* | |
| 1039 (select-window *br-prev-listing-window*) | |
| 1040 (other-window 1)) | |
| 1041 (setq *br-prev-listing-window* nil)) | |
| 1042 (br-to-view-window))) | |
| 1043 | |
| 1044 (defun br-toggle-c-tags () | |
| 1045 "Toggle the value of the 'br-c-tags-flag' flag." | |
| 1046 (interactive) | |
| 1047 (setq br-c-tags-flag (not br-c-tags-flag)) | |
| 1048 (message "C constructs will %sbe added to C-based language Environments." | |
| 1049 (if br-c-tags-flag "" "not "))) | |
| 1050 | |
| 1051 (defun br-toggle-keep-viewed () | |
| 1052 "Toggle the value of the 'br-keep-viewed-classes' flag." | |
| 1053 (interactive) | |
| 1054 (setq br-keep-viewed-classes (not br-keep-viewed-classes)) | |
| 1055 (message "Viewed classes will no%s be kept after use." | |
| 1056 (if br-keep-viewed-classes "w" "t"))) | |
| 1057 | |
| 1058 (defun br-top-classes (&optional arg) | |
| 1059 "Display list of top level classes. | |
| 1060 With prefix ARG, display all Environment classes." | |
| 1061 (interactive "P") | |
| 1062 (and (or (not (interactive-p)) | |
| 1063 (br-in-top-buffer-p) | |
| 1064 (y-or-n-p "Exit to top-level class listing buffer? ")) | |
| 1065 (cond (arg | |
| 1066 (br-show-top-classes 'br-all-classes 'uniq) | |
| 1067 (message "Listing of all Environment classes")) | |
| 1068 (t | |
| 1069 (br-show-top-classes 'br-get-top-classes 'uniq) | |
| 1070 (message "Listing of top-level classes"))) | |
| 1071 (setq *br-level-hist* nil))) | |
| 1072 | |
| 1073 (defun br-unique () | |
| 1074 "Eliminate adjacent duplicate entry names from the current listing window. | |
| 1075 If two adjacent entries look the same one is eliminated, even if they refer | |
| 1076 to different class elements." | |
| 1077 (interactive) | |
| 1078 (let ((buffer-read-only) | |
| 1079 (again t) | |
| 1080 first second) | |
| 1081 (goto-char (point-min)) | |
| 1082 (setq first (br-feature-current)) | |
| 1083 (while again | |
| 1084 (setq again (= (forward-line 1) 0) | |
| 1085 second (br-feature-current)) | |
| 1086 (if (not (string-equal first second)) | |
| 1087 (setq first second) | |
| 1088 (beginning-of-line) | |
| 1089 (delete-region (point) (progn (forward-line 1) (point))) | |
| 1090 ;; back up to first line again | |
| 1091 (forward-line -1))) | |
| 1092 (goto-char (point-min)))) | |
| 1093 | |
| 1094 (defun br-version () | |
| 1095 "Display browser version number and credits." | |
| 1096 (interactive) | |
| 1097 (br-file-to-viewer "BR-VERSION") | |
| 1098 (br-funcall-in-view-window | |
| 1099 (concat br-buffer-prefix-info "Help") | |
| 1100 (function (lambda () | |
| 1101 (if (re-search-forward "<VERSION>" nil t) | |
| 1102 (replace-match br-version t t)) | |
| 1103 (center-line) | |
| 1104 (set-buffer-modified-p nil))) | |
| 1105 t)) | |
| 1106 | |
| 1107 (defun br-view-entry (&optional prompt) | |
| 1108 "Displays source for any browser listing entry. | |
| 1109 Optional prefix arg PROMPT means prompt for entry name." | |
| 1110 (interactive "P") | |
| 1111 (let ((entry) (sig)) | |
| 1112 (if prompt | |
| 1113 (cond ((and (setq entry (br-complete-entry)) | |
| 1114 (string-match br-feature-signature-regexp entry)) | |
| 1115 (if (setq sig (car (br-feature-signature-and-file entry))) | |
| 1116 (br-feature nil 'view sig) | |
| 1117 (error "(br-feature-signature-and-file): Couldn't find match for: '%s'" entry))) | |
| 1118 (entry ;; class name | |
| 1119 (br-view nil nil entry)) | |
| 1120 (t (error "(br-complete-entry): Exited without selecting a match"))) | |
| 1121 (cond ((br-find-feature-entry) | |
| 1122 (br-feature nil 'view)) | |
| 1123 ((and (setq entry (br-find-class-name)) | |
| 1124 (br-class-in-table-p entry)) | |
| 1125 (br-view nil nil entry)) | |
| 1126 (t (error "(OO-Browser): Entry may be referenced but not defined in the Environment.")))))) | |
| 1127 | |
| 1128 (defun br-view (&optional prompt writable class) | |
| 1129 "Displays class file in viewer window. | |
| 1130 Optional prefix arg PROMPT means prompt for class name. Non-nil WRITABLE means | |
| 1131 allow editing, otherwise display in read-only mode. Non-nil CLASS is class to | |
| 1132 display. | |
| 1133 | |
| 1134 Return t if class is displayed or sent to an external viewer, else nil." | |
| 1135 (interactive "P") | |
| 1136 (or class (setq class (if prompt (br-complete-class-name) | |
| 1137 (br-find-class-name)))) | |
| 1138 (cond ((null class) | |
| 1139 (beep) | |
| 1140 (message "(OO-Browser): Select a class to view.") | |
| 1141 nil) | |
| 1142 ((not (br-class-defined-p class)) nil) | |
| 1143 ((and hyperb:window-system | |
| 1144 (cond ((and br-editor-cmd writable) | |
| 1145 (br-edit-ext br-editor-cmd (br-class-path class)) | |
| 1146 t) | |
| 1147 (br-viewer-cmd | |
| 1148 (br-view-ext br-viewer-cmd (br-class-path class)) | |
| 1149 t)))) | |
| 1150 ;; Support custom Lisp-based edit/view cmds on any display type | |
| 1151 ((and br-editor-cmd writable (not (stringp br-editor-cmd))) | |
| 1152 (br-edit-ext br-editor-cmd (br-class-path class)) | |
| 1153 t) | |
| 1154 ((and br-viewer-cmd (not (stringp br-viewer-cmd))) | |
| 1155 (br-view-ext br-viewer-cmd (br-class-path class)) | |
| 1156 t) | |
| 1157 (t (let ((owind (selected-window))) | |
| 1158 (unwind-protect | |
| 1159 (progn (br-to-view-window) | |
| 1160 (if (and (not br-keep-viewed-classes) buffer-read-only | |
| 1161 (null (buffer-modified-p))) | |
| 1162 (kill-buffer (current-buffer))) | |
| 1163 (if (br-find-class class (not writable)) | |
| 1164 (progn (br-major-mode) | |
| 1165 (if writable | |
| 1166 (if (file-writable-p (buffer-file-name)) | |
| 1167 (setq buffer-read-only nil)) | |
| 1168 (setq buffer-read-only t) | |
| 1169 (select-window owind)) | |
| 1170 t))) | |
| 1171 (or writable (select-window owind))))))) | |
| 1172 | |
| 1173 (defun br-view-ext (viewer-cmd file) | |
| 1174 "Invoke a non-standard VIEWER-CMD on FILE. | |
| 1175 See also 'br-viewer-cmd'." | |
| 1176 (interactive "fFile to view: ") | |
| 1177 (or viewer-cmd (setq viewer-cmd br-viewer-cmd)) | |
| 1178 (if (not (stringp viewer-cmd)) ;; must be a Lisp function that takes a | |
| 1179 ;; single, file arg | |
| 1180 (funcall viewer-cmd file) | |
| 1181 (setq delete-exited-processes t) | |
| 1182 (let ((proc) | |
| 1183 (name (concat br-vw-name br-vw-num)) | |
| 1184 ) | |
| 1185 (setq br-vw-num (1+ br-vw-num) | |
| 1186 proc (br-view-ext-start viewer-cmd name file)) | |
| 1187 (if proc | |
| 1188 (process-kill-without-query proc) | |
| 1189 (beep) | |
| 1190 (message "(OO-Browser): Could not start external view process: %s" | |
| 1191 viewer-cmd))))) | |
| 1192 | |
| 1193 (defun br-view-full-frame () | |
| 1194 "Delete all windows in the selected frame except for the viewer window." | |
| 1195 (interactive) | |
| 1196 (setq *br-save-wconfig* (current-window-configuration)) | |
| 1197 (br-to-view-window) | |
| 1198 (let ((buf (current-buffer))) | |
| 1199 (br-interrupt) | |
| 1200 (delete-other-windows) | |
| 1201 (switch-to-buffer buf)) | |
| 1202 (let* ((cmd (concat br-lang-prefix "browse")) | |
| 1203 (key (car (where-is-internal (intern-soft cmd))))) | |
| 1204 (message "Recall OO-Browser with: {%s}" | |
| 1205 (if key | |
| 1206 (key-description key) | |
| 1207 (concat (key-description | |
| 1208 (or (car (where-is-internal | |
| 1209 'execute-extended-command)) | |
| 1210 "\M-x")) | |
| 1211 " " cmd))))) | |
| 1212 | |
| 1213 (defun br-viewer-kill () | |
| 1214 "Kill all current external viewer sub-processes." | |
| 1215 (interactive) | |
| 1216 (if (br-kill-process-group br-vw-name br-vw-num "external viewers") | |
| 1217 (setq br-vw-num 0))) | |
| 1218 | |
| 1219 (defun br-viewer-scroll-down (&optional arg) | |
| 1220 "Scroll viewer window downward ARG lines or a windowful if no ARG." | |
| 1221 (interactive "P") | |
| 1222 (let ((owind (selected-window))) | |
| 1223 (unwind-protect | |
| 1224 (progn (br-to-view-window) | |
| 1225 (scroll-down arg)) | |
| 1226 (select-window owind)))) | |
| 1227 | |
| 1228 (defun br-viewer-scroll-up (&optional arg) | |
| 1229 "Scroll viewer window upward ARG lines or a windowful if no ARG." | |
| 1230 (interactive "P") | |
| 1231 (let ((owind (selected-window))) | |
| 1232 (unwind-protect | |
| 1233 (progn (br-to-view-window) | |
| 1234 (scroll-up arg)) | |
| 1235 (select-window owind)))) | |
| 1236 | |
| 1237 (defun br-where (&optional prompt) | |
| 1238 "Display in minibuffer and return full path of a browser listing entry. | |
| 1239 Optional prefix arg PROMPT means prompt for entry name." | |
| 1240 (interactive "P") | |
| 1241 (let ((entry) (path)) | |
| 1242 (if prompt | |
| 1243 (cond ((and (setq entry (br-complete-entry)) | |
| 1244 (string-match br-feature-signature-regexp entry)) | |
| 1245 (setq path (cdr (br-feature-signature-and-file entry)))) | |
| 1246 (entry ;; class name | |
| 1247 (setq path (br-class-defined-p entry))) | |
| 1248 (t (error "(br-complete-entry): Exited without selecting a match"))) | |
| 1249 (cond ((setq entry (br-find-feature-entry)) | |
| 1250 (setq path (cdr (br-feature-signature-and-file entry)))) | |
| 1251 ((setq entry (br-find-class-name)) | |
| 1252 (or (setq path (br-class-path entry)) | |
| 1253 (error "(OO-Browser): No path for this class in current Environment"))) | |
| 1254 (t (error "(OO-Browser): No entry for current line in current Environment")))) | |
| 1255 (and path (message (concat entry ": " "\"" path "\"")) | |
| 1256 path))) | |
| 1257 | |
| 1258 (defun br-write-buffer (file) | |
| 1259 "Write narrowed portion of current browser buffer to a file." | |
| 1260 (interactive "FFile to write buffer to: ") | |
| 1261 (write-region (point-min) (point-max) file)) | |
| 1262 | |
| 1263 ;;; ************************************************************************ | |
| 1264 ;;; Private functions | |
| 1265 ;;; ************************************************************************ | |
| 1266 | |
| 1267 (defun br-add-level-hist () | |
| 1268 ;; Even though this next line looks useless, it cures a problem with | |
| 1269 ;; window buffer correspondences when the OO-Browser is started, so don't | |
| 1270 ;; remove it. | |
| 1271 (set-buffer (window-buffer (selected-window))) | |
| 1272 (setq *br-level-hist* | |
| 1273 (cons (list (selected-window) (buffer-name) (br-wind-line-at-point)) | |
| 1274 *br-level-hist*))) | |
| 1275 | |
| 1276 (defun br-ancestor-roots (class-list) | |
| 1277 "Return list of CLASS-LIST's unique ancestors which do not inherit from any other class. | |
| 1278 This list may include elements from CLASS-LIST itself." | |
| 1279 (let ((rtn) (parents) func) | |
| 1280 (setq func (function | |
| 1281 (lambda (class-list) | |
| 1282 (mapcar | |
| 1283 (function | |
| 1284 (lambda (class) | |
| 1285 (if (not (setq parents (br-get-parents class))) | |
| 1286 (setq rtn (cons class rtn)) | |
| 1287 (funcall func parents)))) | |
| 1288 class-list)))) | |
| 1289 (funcall func class-list) | |
| 1290 (br-set-of-strings (sort rtn 'string-lessp)))) | |
| 1291 | |
| 1292 (defun br-ancestor-trees-inverted (class-list &optional depth offset) | |
| 1293 "Insert ancestor trees starting with classes from CLASS-LIST. | |
| 1294 Ancestor trees are inverted, i.e. parents appear below children, not above. | |
| 1295 Indent each class in CLASS-LIST by optional DEPTH spaces (default is 0 in | |
| 1296 order to ensure proper initialization). Offset each child level by optional | |
| 1297 OFFSET spaces from its parent (which must be greater than zero, default 2)." | |
| 1298 (or offset (setq offset 2)) | |
| 1299 (or depth (setq depth 0)) | |
| 1300 (if (= depth 0) (setq br-tmp-class-set nil)) | |
| 1301 (let ((prev-expansion-str " ...") | |
| 1302 parents expand-subtree) | |
| 1303 (mapcar | |
| 1304 (function | |
| 1305 (lambda (class) | |
| 1306 (setq expand-subtree (br-set-cons br-tmp-class-set class) | |
| 1307 parents (if expand-subtree (br-get-parents class))) | |
| 1308 (indent-to depth) | |
| 1309 (insert class) | |
| 1310 (and (not expand-subtree) (br-has-children-p class) | |
| 1311 (insert prev-expansion-str)) | |
| 1312 (insert "\n") | |
| 1313 (if br-ancestor-function | |
| 1314 (funcall br-ancestor-function | |
| 1315 class (not expand-subtree) (+ depth offset))) | |
| 1316 (if parents | |
| 1317 (br-ancestor-trees-inverted parents (+ depth offset) offset)))) | |
| 1318 class-list)) | |
| 1319 (if (= depth 0) (setq br-tmp-class-set nil))) | |
| 1320 | |
| 1321 (defun br-ancestor-trees (class-list &optional depth offset) | |
| 1322 "Insert ancestor trees starting with classes from CLASS-LIST. | |
| 1323 Ancestor trees are not inverted, parents appear above children as in other | |
| 1324 browser listing windows. Indent each class in CLASS-LIST by optional DEPTH | |
| 1325 spaces (default is 0 in order to ensure proper initialization). Offset each | |
| 1326 child level by optional OFFSET spaces from its parent (which must be greater | |
| 1327 than zero, default 2)." | |
| 1328 (or offset (setq offset 2)) | |
| 1329 (or depth (setq depth 0 br-tmp-depth 0)) | |
| 1330 (if (= depth 0) (setq br-tmp-class-set nil)) | |
| 1331 (let ((prev-expansion-str " ...") | |
| 1332 parents expand-subtree) | |
| 1333 (mapcar (function | |
| 1334 (lambda (class) | |
| 1335 (setq expand-subtree (br-set-cons br-tmp-class-set class) | |
| 1336 parents (if expand-subtree (br-get-parents class))) | |
| 1337 (if parents | |
| 1338 (progn (setq br-tmp-depth | |
| 1339 (max (+ depth offset) br-tmp-depth)) | |
| 1340 (br-ancestor-trees | |
| 1341 parents (+ depth offset) offset))) | |
| 1342 (indent-to (- br-tmp-depth depth)) | |
| 1343 (insert class) | |
| 1344 (and (not expand-subtree) (br-has-parents-p class) | |
| 1345 (insert prev-expansion-str)) | |
| 1346 (insert "\n") | |
| 1347 (if br-ancestor-function | |
| 1348 (funcall br-ancestor-function | |
| 1349 class (not expand-subtree) (+ depth offset))) | |
| 1350 (if (= depth 0) (setq br-tmp-depth 0)))) | |
| 1351 class-list)) | |
| 1352 (if (= depth 0) (setq br-tmp-class-set nil))) | |
| 1353 | |
| 1354 (defun br-browser-buffer-p (&optional buffer) | |
| 1355 "Returns t iff optional BUFFER or current buffer is an OO-Browser specific buffer." | |
| 1356 (equal 0 (string-match (concat br-buffer-prefix-inher | |
| 1357 "\\|" br-buffer-prefix-categ | |
| 1358 "\\|" br-buffer-prefix-blank | |
| 1359 "\\|" br-buffer-prefix-info) | |
| 1360 (buffer-name buffer)))) | |
| 1361 | |
| 1362 (defun br-buffer-level () | |
| 1363 "Returns current listing buffer level as a string." | |
| 1364 (let* ((name (buffer-name)) | |
| 1365 (pos (string-match "-[p]*[0-9]+$" name))) | |
| 1366 (and pos (substring name (1+ pos))))) | |
| 1367 | |
| 1368 (defun br-class-level () | |
| 1369 "Returns current class hierarchy level as an integer. | |
| 1370 1 is the top level." | |
| 1371 (let* ((name (buffer-name)) | |
| 1372 (pos (string-match "[0-9]" name))) | |
| 1373 (and pos (string-to-int (substring name pos))))) | |
| 1374 | |
| 1375 (defun br-listing-window-num () | |
| 1376 "Return listing window number, lefmost is 1, non-listing window = 0." | |
| 1377 (let ((wind (selected-window)) | |
| 1378 (ctr 0)) | |
| 1379 (br-to-view-window) | |
| 1380 (while (not (eq wind (selected-window))) | |
| 1381 (other-window 1) | |
| 1382 (setq ctr (1+ ctr))) | |
| 1383 ctr)) | |
| 1384 | |
| 1385 (defun br-cleanup () | |
| 1386 "Cleanup and free browser Environment data structures." | |
| 1387 (setq br-lang-prefix nil | |
| 1388 br-sys-paths-htable nil | |
| 1389 br-lib-paths-htable nil | |
| 1390 br-paths-htable nil | |
| 1391 br-sys-parents-htable nil | |
| 1392 br-lib-parents-htable nil | |
| 1393 br-parents-htable nil | |
| 1394 br-children-htable nil | |
| 1395 br-lib-prev-search-dirs nil | |
| 1396 br-sys-prev-search-dirs nil | |
| 1397 )) | |
| 1398 | |
| 1399 (defun br-clear () | |
| 1400 "Re-initialize all browser listing buffer displays. | |
| 1401 Leave point in browser top-level class listing buffer." | |
| 1402 (let ((n (max 1 (/ (frame-width) br-min-width-window)))) | |
| 1403 (br-to-view-window) | |
| 1404 (other-window 1) | |
| 1405 (br-next-buffer 1) | |
| 1406 (while (> n 1) | |
| 1407 (setq n (1- n)) | |
| 1408 (br-next-buffer nil br-buffer-prefix-blank)) | |
| 1409 (br-to-view-window) | |
| 1410 (other-window 1))) | |
| 1411 | |
| 1412 (defun br-descendant-trees (class-list &optional indent offset) | |
| 1413 "Insert descendant trees starting with classes from CLASS-LIST. | |
| 1414 Indent each class in CLASS-LIST by optional INDENT spaces (default is 0 in | |
| 1415 order to ensure proper initialization). Offset each child level by optional | |
| 1416 OFFSET spaces from its parent (which must be greater than zero, default 2)." | |
| 1417 (or indent (setq indent 0)) | |
| 1418 (or offset (setq offset 2)) | |
| 1419 (if (= indent 0) (setq br-tmp-class-set nil)) | |
| 1420 (let ((prev-expansion-str " ...") | |
| 1421 children expand-subtree) | |
| 1422 (mapcar (function | |
| 1423 (lambda (class) | |
| 1424 (setq expand-subtree (br-set-cons br-tmp-class-set class) | |
| 1425 children (if expand-subtree (br-get-children class))) | |
| 1426 (indent-to indent) | |
| 1427 (insert class) | |
| 1428 (and (not expand-subtree) (br-has-children-p class) | |
| 1429 (insert prev-expansion-str)) | |
| 1430 (insert "\n") | |
| 1431 (if children | |
| 1432 (br-descendant-trees children (+ indent offset) offset)))) | |
| 1433 class-list)) | |
| 1434 (if (= indent 0) (setq br-tmp-class-set nil))) | |
| 1435 | |
| 1436 (defun br-display-buffer (suffix) | |
| 1437 "Displays browser buffer ending in SUFFIX in current window." | |
| 1438 (let ((buf (get-buffer (concat br-buffer-prefix suffix)))) | |
| 1439 (if buf (progn (set-window-buffer (selected-window) buf))) | |
| 1440 buf)) | |
| 1441 | |
| 1442 (defun br-do-in-view-window (form) | |
| 1443 "Evaluate FORM in viewer window and then return to current window." | |
| 1444 (interactive) | |
| 1445 (let ((wind (selected-window))) | |
| 1446 (unwind-protect | |
| 1447 (progn (br-to-view-window) | |
| 1448 (eval form)) | |
| 1449 (select-window wind)))) | |
| 1450 | |
| 1451 (defun br-edit-ext-start (editor-cmd name file) | |
| 1452 "Start an external viewer given by EDITOR-CMD using NAME applied to FILE." | |
| 1453 ;; Conditionalized code is necessary because of silly (start-process) calling | |
| 1454 ;; protocol. | |
| 1455 (cond (br-ed9 | |
| 1456 (start-process name name editor-cmd br-ed1 br-ed2 br-ed3 br-ed4 | |
| 1457 br-ed5 br-ed6 br-ed7 br-ed8 br-ed9 file)) | |
| 1458 (br-ed8 | |
| 1459 (start-process name name editor-cmd br-ed1 br-ed2 br-ed3 br-ed4 | |
| 1460 br-ed5 br-ed6 br-ed7 br-ed8 file)) | |
| 1461 (br-ed7 | |
| 1462 (start-process name name editor-cmd br-ed1 br-ed2 br-ed3 br-ed4 | |
| 1463 br-ed5 br-ed6 br-ed7 file)) | |
| 1464 (br-ed6 | |
| 1465 (start-process name name editor-cmd br-ed1 br-ed2 br-ed3 br-ed4 | |
| 1466 br-ed5 br-ed6 file)) | |
| 1467 (br-ed5 | |
| 1468 (start-process name name editor-cmd br-ed1 br-ed2 br-ed3 br-ed4 | |
| 1469 br-ed5 file)) | |
| 1470 (br-ed4 | |
| 1471 (start-process name name editor-cmd br-ed1 br-ed2 br-ed3 br-ed4 | |
| 1472 file)) | |
| 1473 (br-ed3 | |
| 1474 (start-process name name editor-cmd br-ed1 br-ed2 br-ed3 file)) | |
| 1475 (br-ed2 | |
| 1476 (start-process name name editor-cmd br-ed1 br-ed2 file)) | |
| 1477 (br-ed1 | |
| 1478 (start-process name name editor-cmd br-ed1 file)) | |
| 1479 (t | |
| 1480 (start-process name name editor-cmd file)) | |
| 1481 )) | |
| 1482 | |
| 1483 (defun br-funcall-in-view-window (buffer function &optional no-erase) | |
| 1484 "Clear out BUFFER and display return value from invocation of FUNCTION in viewer window. | |
| 1485 Move point to beginning of buffer and then return to current window. BUFFER | |
| 1486 may be a buffer name. | |
| 1487 With optional NO-ERASE, buffer is not erased before function is called." | |
| 1488 (interactive) | |
| 1489 (let ((wind (selected-window))) | |
| 1490 (unwind-protect | |
| 1491 (progn (br-to-view-window) | |
| 1492 (set-window-buffer (selected-window) (get-buffer-create buffer)) | |
| 1493 (let (buffer-read-only) | |
| 1494 (if no-erase | |
| 1495 (goto-char (point-min)) | |
| 1496 (erase-buffer)) | |
| 1497 (funcall function)) | |
| 1498 (goto-char (point-min))) | |
| 1499 (select-window wind)))) | |
| 1500 | |
| 1501 (defun br-file-to-viewer (filename) | |
| 1502 "Display FILENAME from OO-Browser source directory in browser viewer window. | |
| 1503 FILENAME should not contain any path information." | |
| 1504 (br-funcall-in-view-window | |
| 1505 (concat br-buffer-prefix-info "Help") | |
| 1506 (function (lambda () | |
| 1507 (insert-file-contents (br-pathname filename)) | |
| 1508 (set-buffer-modified-p nil))))) | |
| 1509 | |
| 1510 (defun br-in-browser () | |
| 1511 "Return selected frame if the OO-Browser is active in it, else return nil." | |
| 1512 (cond ((not (eq br-in-browser (selected-frame))) nil) | |
| 1513 ((one-window-p 'nomini) | |
| 1514 (setq br-in-browser nil)) | |
| 1515 (t br-in-browser))) | |
| 1516 | |
| 1517 | |
| 1518 (defun br-in-top-buffer-p () | |
| 1519 "Return t if point is in the top class listing buffer, else nil." | |
| 1520 (string-equal (br-buffer-level) "1")) | |
| 1521 | |
| 1522 (defun br-in-view-window-p () | |
| 1523 "Is point in a viewer window?" | |
| 1524 (br-non-listing-window-p)) | |
| 1525 | |
| 1526 (defun br-init () | |
| 1527 "Initialization common to all OO-Browser invocations." | |
| 1528 (br-feature-tags-init)) | |
| 1529 | |
| 1530 (defun br-insert-classes (class-list &optional indent) | |
| 1531 "Insert CLASS-LIST in current buffer indented INDENT columns." | |
| 1532 (mapcar (function | |
| 1533 (lambda (class-name) | |
| 1534 (and indent (indent-to indent)) | |
| 1535 (and class-name (insert class-name "\n")))) | |
| 1536 class-list)) | |
| 1537 | |
| 1538 (defun br-interrupt (&optional arg) | |
| 1539 (if (null arg) | |
| 1540 (mapcar | |
| 1541 (function | |
| 1542 (lambda (buf) | |
| 1543 (set-buffer buf) | |
| 1544 (if (or (eq major-mode 'br-mode) (br-browser-buffer-p)) | |
| 1545 (bury-buffer nil)))) | |
| 1546 (buffer-list)) | |
| 1547 (setq *br-save-wconfig* nil | |
| 1548 *br-prev-wconfig* nil | |
| 1549 *br-prev-listing-window* nil) | |
| 1550 (mapcar | |
| 1551 (function | |
| 1552 (lambda (buf) | |
| 1553 (set-buffer buf) | |
| 1554 (if (or (eq major-mode 'br-mode) | |
| 1555 (br-browser-buffer-p)) | |
| 1556 (progn (br-feature-clear-signatures) | |
| 1557 (set-buffer-modified-p nil) | |
| 1558 (kill-buffer (current-buffer)))))) | |
| 1559 (buffer-list)) | |
| 1560 (br-cleanup)) | |
| 1561 (setq br-in-browser nil)) | |
| 1562 | |
| 1563 (defun br-mode () | |
| 1564 "The major mode used by OO-Browser listing windows. | |
| 1565 See the file \"br-help\" for browser usage information. | |
| 1566 It provides the following keys: \\{br-mode-map}" | |
| 1567 (interactive) | |
| 1568 (use-local-map br-mode-map) | |
| 1569 (setq major-mode 'br-mode) | |
| 1570 (setq mode-name "OO-Browse") | |
| 1571 (set-syntax-table text-mode-syntax-table) | |
| 1572 (setq local-abbrev-table text-mode-abbrev-table) | |
| 1573 (setq case-fold-search t) | |
| 1574 (setq buffer-read-only t) | |
| 1575 (run-hooks 'br-class-list-hook) | |
| 1576 (run-hooks 'br-mode-hook)) | |
| 1577 | |
| 1578 (defun br-narrow-to-class () | |
| 1579 (cond ((= (point-min) (point-max)) nil) | |
| 1580 ((br-find-class-name) | |
| 1581 (narrow-to-region (match-beginning 0) (match-end 0))) | |
| 1582 (t (error | |
| 1583 "(OO-Browser): 'br-narrow-to-class', current entry is not a class")))) | |
| 1584 | |
| 1585 (defun br-narrow-to-feature () | |
| 1586 "Narrow buffer to current feature entry." | |
| 1587 (if (br-feature-at-p) | |
| 1588 (narrow-to-region (match-beginning 0) (match-end 0)) | |
| 1589 (error | |
| 1590 "(OO-Browser): 'br-narrow-to-feature' no current feature."))) | |
| 1591 | |
| 1592 (defun br-feature-at-p () | |
| 1593 "Returns t iff point is on a feature listing line." | |
| 1594 (save-excursion | |
| 1595 (beginning-of-line) | |
| 1596 (looking-at (concat "[ \t]*" br-feature-entry)))) | |
| 1597 | |
| 1598 (defun br-next-buffer (&optional special alt-prefix) | |
| 1599 "Returns next sequential browser buffer or special one if optional SPECIAL is non-nil. | |
| 1600 Non-nil ALT-PREFIX is used as prefix in buffer name." | |
| 1601 (let* ((suffix (or special (1+ (or (br-class-level) 0)))) | |
| 1602 (buf (get-buffer-create | |
| 1603 (concat (or alt-prefix br-buffer-prefix) | |
| 1604 (if (integerp suffix) | |
| 1605 (int-to-string suffix) | |
| 1606 suffix))))) | |
| 1607 (if buf (progn | |
| 1608 (or special (br-next-listing-window)) | |
| 1609 (set-window-buffer (selected-window) buf) | |
| 1610 (let (buffer-read-only) | |
| 1611 (erase-buffer) | |
| 1612 (kill-all-local-variables) | |
| 1613 ;; Clear out any feature tags that may have been associated | |
| 1614 ;; with this buffer, so we don't mistakenly reference them. | |
| 1615 (br-feature-clear-signatures)) | |
| 1616 (setq mode-line-format (list " %17b --" '(-3 . "%p") "-%-")) | |
| 1617 (br-mode) | |
| 1618 (br-set-mode-line) | |
| 1619 (set-buffer-modified-p nil))) | |
| 1620 buf)) | |
| 1621 | |
| 1622 (defun br-next-listing-window (&optional prev) | |
| 1623 "Move to next browser listing window (non-viewer window). | |
| 1624 Optional PREV means to previous window." | |
| 1625 (let ((owind (selected-window))) | |
| 1626 (while (progn (other-window (if prev -1 1)) | |
| 1627 (if (br-non-listing-window-p) | |
| 1628 (not (eq (selected-window) owind))))))) | |
| 1629 | |
| 1630 (defun br-pathname (filename) | |
| 1631 "Return full pathname for FILENAME in browser Elisp directory." | |
| 1632 (if br-directory | |
| 1633 (expand-file-name filename br-directory) | |
| 1634 (error "The 'br-directory' variable must be set to a string value."))) | |
| 1635 | |
| 1636 (defun br-protocol-entry-p () | |
| 1637 "Return non-nil if point is within a protocol listing entry line." | |
| 1638 (and (string-equal br-lang-prefix "objc-") | |
| 1639 (save-excursion | |
| 1640 (beginning-of-line) | |
| 1641 (looking-at "[ \t]*@ <[^\>]*>")))) | |
| 1642 | |
| 1643 (defun br-resize (min-width) | |
| 1644 "Resize browser listing windows to have MIN-WIDTH." | |
| 1645 (interactive) | |
| 1646 (let* ((window-min-width 3) | |
| 1647 (oldn (1- (length (br-window-list)))) | |
| 1648 (n (max 1 (/ (frame-width) min-width))) | |
| 1649 (numw n) | |
| 1650 (diff (- numw oldn)) | |
| 1651 (width (/ (frame-width) numw)) | |
| 1652 (obuf (current-buffer))) | |
| 1653 (br-to-first-list-window) | |
| 1654 (cond ((= diff 0) | |
| 1655 (br-resize-windows numw width)) | |
| 1656 ((> diff 0) | |
| 1657 (setq n oldn) | |
| 1658 (while (> n 1) | |
| 1659 (setq n (1- n)) | |
| 1660 (shrink-window-horizontally (max 0 (- (window-width) | |
| 1661 min-width))) | |
| 1662 (br-next-listing-window)) | |
| 1663 (setq n diff) | |
| 1664 (while (> n 0) | |
| 1665 (setq n (1- n)) | |
| 1666 (split-window-horizontally (max window-min-width | |
| 1667 (- (window-width) | |
| 1668 min-width)))) | |
| 1669 (setq n oldn) | |
| 1670 (while (< n numw) | |
| 1671 (setq n (1+ n)) | |
| 1672 (br-next-listing-window) | |
| 1673 (br-next-buffer n br-buffer-prefix-blank)) | |
| 1674 (br-to-first-list-window) | |
| 1675 (br-resize-windows numw width) | |
| 1676 ) | |
| 1677 (t ;; (< diff 0) | |
| 1678 (while (> n 0) | |
| 1679 (setq n (1- n)) | |
| 1680 (br-next-listing-window)) | |
| 1681 (setq n (- diff)) | |
| 1682 (while (> n 0) | |
| 1683 (setq n (1- n)) | |
| 1684 (delete-window)) | |
| 1685 (br-to-first-list-window) | |
| 1686 (br-resize-windows numw width) | |
| 1687 )) | |
| 1688 (setq br-min-width-window min-width) | |
| 1689 (let ((owind (get-buffer-window obuf))) | |
| 1690 (if owind | |
| 1691 (select-window owind) | |
| 1692 (br-to-view-window) | |
| 1693 (br-next-listing-window))))) | |
| 1694 | |
| 1695 (defun br-resize-narrow () | |
| 1696 "Resize listing windows so are narrower by 10 characters." | |
| 1697 (interactive) | |
| 1698 (if (<= window-min-width (- br-min-width-window 10)) | |
| 1699 (br-resize (max window-min-width (- br-min-width-window 10))) | |
| 1700 (beep))) | |
| 1701 | |
| 1702 (defun br-resize-widen () | |
| 1703 "Resize listing windows so are wider by 10 characters." | |
| 1704 (interactive) | |
| 1705 (if (and (>= (frame-width) (+ br-min-width-window 10)) | |
| 1706 (> (length (br-window-list)) 2)) | |
| 1707 (br-resize (min (frame-width) (+ br-min-width-window 10))) | |
| 1708 (beep))) | |
| 1709 | |
| 1710 (defun br-resize-windows (n width) | |
| 1711 (while (> n 1) | |
| 1712 (setq n (1- n)) | |
| 1713 (shrink-window-horizontally (- (window-width) width)) | |
| 1714 (br-next-listing-window))) | |
| 1715 | |
| 1716 (defun br-set-mode-line () | |
| 1717 "Set mode line string." | |
| 1718 (setq mode-line-buffer-identification (list (buffer-name))) | |
| 1719 (set-buffer-modified-p t)) | |
| 1720 | |
| 1721 (defun br-show-top-classes (func &optional uniq) | |
| 1722 "Display list of top level classes generated by calling FUNC. | |
| 1723 Optional UNIQ means sort and eliminate duplicates." | |
| 1724 (message "Ordering classes...") | |
| 1725 (let ((classes (funcall func))) | |
| 1726 (setq classes (br-class-list-filter classes)) | |
| 1727 (br-clear) | |
| 1728 (let (buffer-read-only) | |
| 1729 (erase-buffer) | |
| 1730 (br-insert-classes classes) | |
| 1731 (if uniq | |
| 1732 (progn | |
| 1733 (if (stringp br-sort-options) | |
| 1734 (call-process-region (point-min) (point-max) "sort" t t nil | |
| 1735 br-sort-options) | |
| 1736 (call-process-region (point-min) (point-max) "sort" t t nil)) | |
| 1737 (if (and (stringp br-sort-options) | |
| 1738 (string-match "u" br-sort-options)) | |
| 1739 ;; Then sort made the list of elements unique, so do nothing. | |
| 1740 nil | |
| 1741 (call-process-region (point-min) (point-max) "uniq" t t)))))) | |
| 1742 (goto-char (point-min)) | |
| 1743 (message "Ordering classes...Done")) | |
| 1744 | |
| 1745 (defun br-this-level-classes (&optional keep-indent) | |
| 1746 "Return list of the classes in the current listing. | |
| 1747 Optional KEEP-INDENT non-nil means keep indentation preceding class name." | |
| 1748 (let ((classes)) | |
| 1749 (save-excursion | |
| 1750 (goto-char (point-min)) | |
| 1751 (while (and (not (looking-at "^[ \t]*$")) | |
| 1752 (if (looking-at (format "^[ \t]*%s " | |
| 1753 br-feature-type-regexp)) ;; a feature | |
| 1754 t ;; skip this entry | |
| 1755 ;; assume is a class | |
| 1756 (setq classes (cons (br-find-class-name keep-indent) | |
| 1757 classes))) | |
| 1758 (= (forward-line 1) 0)))) | |
| 1759 (nreverse (delq nil classes)))) | |
| 1760 | |
| 1761 (defun br-this-level-entries () | |
| 1762 "Return list of all entries in the current listing." | |
| 1763 (let ((entries)) | |
| 1764 (save-excursion | |
| 1765 (goto-char (point-min)) | |
| 1766 (while (and (not (looking-at "^[ \t]*$")) | |
| 1767 (if (looking-at (format "^[ \t]*%s " | |
| 1768 br-feature-type-regexp)) ;; a feature | |
| 1769 (setq entries | |
| 1770 (cons (br-find-feature-entry) entries)) | |
| 1771 ;; assume is a class | |
| 1772 (setq entries (cons (br-find-class-name) entries))) | |
| 1773 (= (forward-line 1) 0)))) | |
| 1774 (nreverse (delq nil entries)))) | |
| 1775 | |
| 1776 (defun br-this-level-features () | |
| 1777 "Return list of features in the current listing." | |
| 1778 (let ((feature-regexp (concat "[ \t]*" br-feature-entry)) | |
| 1779 (features)) | |
| 1780 (save-excursion | |
| 1781 (goto-char (point-min)) | |
| 1782 (while (progn (if (looking-at feature-regexp) | |
| 1783 (setq features | |
| 1784 (cons (br-find-feature-entry) features))) | |
| 1785 (= (forward-line 1) 0)))) | |
| 1786 (nreverse (delq nil features)))) | |
| 1787 | |
| 1788 (defun br-to-first-list-window () | |
| 1789 (br-to-view-window) | |
| 1790 (br-next-listing-window)) | |
| 1791 | |
| 1792 (defun br-to-tree () | |
| 1793 "If point is within ... move to inher/ancestry expansion for the current class." | |
| 1794 (if (save-excursion | |
| 1795 (skip-chars-backward ".") | |
| 1796 (looking-at "\\.\\.\\.")) | |
| 1797 (progn (beginning-of-line) | |
| 1798 (let ((class-expr (concat "^[ \t]*" | |
| 1799 (br-find-class-name) | |
| 1800 "$"))) | |
| 1801 (if (re-search-backward class-expr nil t) | |
| 1802 (progn (skip-chars-forward " \t") | |
| 1803 (recenter '(4)) | |
| 1804 t)))))) | |
| 1805 | |
| 1806 (defun br-to-view-window () | |
| 1807 "Move to viewer window." | |
| 1808 (if (br-in-view-window-p) | |
| 1809 nil | |
| 1810 (setq *br-prev-listing-window* (selected-window)) | |
| 1811 (while (and (not (br-in-view-window-p)) | |
| 1812 (progn (other-window 1) | |
| 1813 (not (eq (selected-window) | |
| 1814 *br-prev-listing-window*))))))) | |
| 1815 | |
| 1816 (defun br-window-setup () | |
| 1817 (and (fboundp 'modify-frame-parameters) | |
| 1818 (cdr (assq 'unsplittable (frame-parameters))) | |
| 1819 (modify-frame-parameters (selected-frame) '((unsplittable)))) | |
| 1820 (delete-other-windows) | |
| 1821 ;; Set top of frame line in case it is not 0. | |
| 1822 (or (fboundp 'window-highest-p) | |
| 1823 (setq br-top-of-frame (nth 1 (window-edges)))) | |
| 1824 (split-window-vertically nil) | |
| 1825 (let* ((n (max 1 (/ (frame-width) br-min-width-window))) | |
| 1826 (width (/ (frame-width) n))) | |
| 1827 (br-next-buffer 1) | |
| 1828 (while (> n 1) | |
| 1829 (setq n (1- n)) | |
| 1830 (split-window-horizontally width) | |
| 1831 (br-next-buffer nil br-buffer-prefix-blank)))) | |
| 1832 | |
| 1833 (defun br-view-ext-start (viewer-cmd name file) | |
| 1834 "Start an external viewer given by VIEWER-CMD using NAME applied to FILE." | |
| 1835 ;; Conditionalized code is necessary because of silly (start-process) calling | |
| 1836 ;; protocol. | |
| 1837 (cond (br-vw9 | |
| 1838 (start-process name name viewer-cmd br-vw1 br-vw2 br-vw3 br-vw4 | |
| 1839 br-vw5 br-vw6 br-vw7 br-vw8 br-vw9 file)) | |
| 1840 (br-vw8 | |
| 1841 (start-process name name viewer-cmd br-vw1 br-vw2 br-vw3 br-vw4 | |
| 1842 br-vw5 br-vw6 br-vw7 br-vw8 file)) | |
| 1843 (br-vw7 | |
| 1844 (start-process name name viewer-cmd br-vw1 br-vw2 br-vw3 br-vw4 | |
| 1845 br-vw5 br-vw6 br-vw7 file)) | |
| 1846 (br-vw6 | |
| 1847 (start-process name name viewer-cmd br-vw1 br-vw2 br-vw3 br-vw4 | |
| 1848 br-vw5 br-vw6 file)) | |
| 1849 (br-vw5 | |
| 1850 (start-process name name viewer-cmd br-vw1 br-vw2 br-vw3 br-vw4 | |
| 1851 br-vw5 file)) | |
| 1852 (br-vw4 | |
| 1853 (start-process name name viewer-cmd br-vw1 br-vw2 br-vw3 br-vw4 | |
| 1854 file)) | |
| 1855 (br-vw3 | |
| 1856 (start-process name name viewer-cmd br-vw1 br-vw2 br-vw3 file)) | |
| 1857 (br-vw2 | |
| 1858 (start-process name name viewer-cmd br-vw1 br-vw2 file)) | |
| 1859 (br-vw1 | |
| 1860 (start-process name name viewer-cmd br-vw1 file)) | |
| 1861 (t | |
| 1862 (start-process name name viewer-cmd file)) | |
| 1863 )) | |
| 1864 | |
| 1865 ;;; ************************************************************************ | |
| 1866 ;;; Private variables | |
| 1867 ;;; ************************************************************************ | |
| 1868 | |
| 1869 (defvar br-ancestor-function nil | |
| 1870 "If non-nil, a function of 3 arguments called after each ancestor class is inserted into an ancestry listing. | |
| 1871 First argument is the class just inserted, second argument is a flag | |
| 1872 indicating whether class has previously been displayed within the listing and | |
| 1873 third argument is the number of spaces to indent each feature entry for this | |
| 1874 class.") | |
| 1875 | |
| 1876 (defvar br-top-of-frame 0 | |
| 1877 "Frame line number of windows at top of the OO-Browser frame.") | |
| 1878 | |
| 1879 (defvar br-ed-num 0) | |
| 1880 (defvar br-ed-name "extEd") | |
| 1881 (defvar br-vw-num 0) | |
| 1882 (defvar br-vw-name "extVw") | |
| 1883 | |
| 1884 (defvar br-in-browser nil | |
| 1885 "Equal to the frame displaying the OO-Browser when in use, else nil.") | |
| 1886 | |
| 1887 (defvar br-lib-search-dirs nil | |
| 1888 "List of directories below which OO source files and other library | |
| 1889 directories are found. A library is a stable group of OO classes. Do not | |
| 1890 set this variable directly. Each OO language library which invokes | |
| 1891 'br-browse' should set it.") | |
| 1892 | |
| 1893 (defvar br-sys-search-dirs nil | |
| 1894 "List of directories below which OO source files and other system | |
| 1895 directories are found. A system is a group of OO classes that are likely to | |
| 1896 change. Do not set this variable directly. Each OO language library which | |
| 1897 invokes 'br-browse' should set it.") | |
| 1898 | |
| 1899 (defvar *br-level-hist* nil | |
| 1900 "Internal history of visited listing windows and buffers.") | |
| 1901 | |
| 1902 (defvar *br-prev-listing-window* nil | |
| 1903 "Saves listing window used prior to viewer window entry. | |
| 1904 Allows return to previous listing window when done with the viewer.") | |
| 1905 | |
| 1906 (defvar *br-prev-wconfig* nil | |
| 1907 "Saves window configuration prior to browser entry.") | |
| 1908 | |
| 1909 (defvar *br-save-wconfig* nil | |
| 1910 "Saves window configuration between invocations of the browser.") | |
| 1911 | |
| 1912 (defconst br-buffer-prefix-categ "Categ-Lvl-") | |
| 1913 (defconst br-buffer-prefix-inher "Inher-Lvl-") | |
| 1914 (defconst br-buffer-prefix-blank "Blank-") | |
| 1915 (defconst br-buffer-prefix-info "OO-Browser ") | |
| 1916 (defvar br-buffer-prefix br-buffer-prefix-inher | |
| 1917 "Browser buffer name prefix.") | |
| 1918 | |
| 1919 | |
| 1920 (defvar br-mode-map nil | |
| 1921 "Keymap containing OO-Browser commands.") | |
| 1922 (if br-mode-map | |
| 1923 nil | |
| 1924 (setq br-mode-map (make-keymap)) | |
| 1925 (suppress-keymap br-mode-map) | |
| 1926 (define-key br-mode-map "@" 'br-at) | |
| 1927 (define-key br-mode-map "1" 'br-view-full-frame) | |
| 1928 (define-key br-mode-map "\C-c^" 'br-add-class-file) | |
| 1929 (define-key br-mode-map "a" 'br-ancestors) | |
| 1930 (define-key br-mode-map "b" 'br-buffer-menu) | |
| 1931 (define-key br-mode-map "\C-c\C-b" 'br-report-bug) | |
| 1932 (define-key br-mode-map "c" 'br-children) | |
| 1933 (define-key br-mode-map "C" 'br-categories) | |
| 1934 (define-key br-mode-map "\M-c" 'br-class-stats) | |
| 1935 (define-key br-mode-map "\C-c\C-c" 'br-env-create) | |
| 1936 (define-key br-mode-map "d" 'br-descendants) | |
| 1937 (define-key br-mode-map "\C-c\C-d" 'br-delete) | |
| 1938 ;; {M-d} is used down below for 'br-tree' | |
| 1939 (define-key br-mode-map "e" 'br-edit-entry) | |
| 1940 (define-key br-mode-map "\M-e" 'br-env-stats) | |
| 1941 (define-key br-mode-map "\C-c\C-e" 'br-env-rebuild) | |
| 1942 (define-key br-mode-map "f" 'br-features) | |
| 1943 (define-key br-mode-map "F" 'br-feature-signature) | |
| 1944 ;; {M-f} is used down below for 'br-tree-features-toggle' | |
| 1945 ;; {M-g} is used down below for 'br-tree-graph' | |
| 1946 (define-key br-mode-map "?" 'br-help) | |
| 1947 (define-key br-mode-map "h" 'br-help) | |
| 1948 (define-key br-mode-map "H" 'br-help-ms) ;; mouse help | |
| 1949 (define-key br-mode-map "i" 'br-entry-info) | |
| 1950 (define-key br-mode-map "I" 'br-implementors) | |
| 1951 (define-key br-mode-map "\C-c\C-k" 'br-kill) | |
| 1952 ;; {M-k} is used down below for 'br-tree-kill' | |
| 1953 (define-key br-mode-map "l" 'br-lib-top-classes) | |
| 1954 (define-key br-mode-map "L" 'br-lib-rebuild) | |
| 1955 (define-key br-mode-map "\C-c\C-l" 'br-env-load) | |
| 1956 (define-key br-mode-map "m" 'br-match) | |
| 1957 (define-key br-mode-map "M" 'br-match-entries) | |
| 1958 ;; "\C-c\C-m" is reserved for future use. | |
| 1959 (define-key br-mode-map "\C-n" 'br-next-entry) | |
| 1960 (define-key br-mode-map "o" 'br-order) | |
| 1961 (define-key br-mode-map "p" 'br-parents) | |
| 1962 (define-key br-mode-map "P" 'br-protocols) | |
| 1963 (define-key br-mode-map "\C-p" 'br-prev-entry) | |
| 1964 (define-key br-mode-map "q" 'br-quit) | |
| 1965 ;; {r} does the same thing as {f} and is for backward compatibility | |
| 1966 ;; with prior OO-Browser releases. It may be rebound in the future, so | |
| 1967 ;; learn to use {f} instead. | |
| 1968 (define-key br-mode-map "r" 'br-features) | |
| 1969 (define-key br-mode-map "\C-c\C-r" 'br-refresh) | |
| 1970 (define-key br-mode-map "s" 'br-sys-top-classes) | |
| 1971 (define-key br-mode-map "S" 'br-sys-rebuild) | |
| 1972 (define-key br-mode-map "\C-c\C-s" 'br-env-save) | |
| 1973 (define-key br-mode-map "t" 'br-top-classes) | |
| 1974 (define-key br-mode-map "u" 'br-unique) | |
| 1975 (define-key br-mode-map "v" 'br-view-entry) | |
| 1976 (define-key br-mode-map "V" 'br-view-friend) | |
| 1977 (define-key br-mode-map "\C-c\C-v" 'br-to-from-viewer) | |
| 1978 (define-key br-mode-map "\C-c\C-w" 'br-write-buffer) | |
| 1979 (define-key br-mode-map "w" 'br-where) | |
| 1980 (define-key br-mode-map "x" 'br-exit-level) | |
| 1981 (define-key br-mode-map "\C-x-" 'br-resize-narrow) | |
| 1982 (define-key br-mode-map "\C-x+" 'br-resize-widen) | |
| 1983 (define-key br-mode-map "#" 'br-count) | |
| 1984 (define-key br-mode-map "\C-c#" 'br-version) | |
| 1985 (define-key br-mode-map " " 'br-viewer-scroll-up) | |
| 1986 (define-key br-mode-map "\177" 'br-viewer-scroll-down) | |
| 1987 ;; | |
| 1988 ;; Define graphical browser keys if a window system is available. | |
| 1989 (if hyperb:window-system | |
| 1990 (progn (require 'br-tree) | |
| 1991 (define-key br-mode-map "\M-d" 'br-tree) | |
| 1992 (define-key br-mode-map "\M-f" 'br-tree-features-toggle) | |
| 1993 (define-key br-mode-map "\M-g" 'br-tree-graph) | |
| 1994 (define-key br-mode-map "\M-k" 'br-tree-kill)))) | |
| 1995 | |
| 1996 (defvar br-tmp-class-set nil | |
| 1997 "Set of classes created for temporary use by br-*-trees functions.") | |
| 1998 (defvar br-tmp-depth 0 | |
| 1999 "Temporary variable indicating inheritance depth of class in 'br-ancestor-trees'.") | |
| 2000 | |
| 2001 (provide 'br) |