4 ;; SUMMARY: Interface between textual and graphical OO-Browsers.
5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: mouse, oop, tools
11 ;; ORIG-DATE: 12-Oct-90
12 ;; LAST-MOD: 9-Jun-99 at 18:05:26 by Bob Weiner
14 ;; Copyright (C) 1990-1995, 1997, 1998 BeOpen.com
15 ;; See the file BR-COPY for license information.
17 ;; This file is part of the OO-Browser.
21 ;; Requires the X Window system Version 11, Windows or NEXTSTEP.
25 ;;; ************************************************************************
26 ;;; Other required Elisp libraries
27 ;;; ************************************************************************
31 ;;; ************************************************************************
33 ;;; ************************************************************************
35 (defvar *br-tree-prog-name*
37 (cond ((or (eq window-system 'x)
41 ((memq window-system '(mswindows win32 w32 pm)) "oobr.exe")
44 (gui-oo-browser (expand-file-name prog br-directory)))
45 ;; Look for program in br-directory, exec-directory and
46 ;; then in user's $PATH.
47 (if (or (file-executable-p gui-oo-browser)
48 (progn (setq gui-oo-browser (expand-file-name prog exec-directory))
49 (file-executable-p gui-oo-browser)))
52 "Program to run for hierarchical display of classes.")
54 ;;; ************************************************************************
56 ;;; ************************************************************************
58 (defun br-tree (&optional arg)
59 "Start the appropriate tree application with descendency tree of current class.
60 With optional prefix ARG, include a descendency tree for each class in
61 the current listing buffer."
63 (let* ((classes (if arg
64 (br-this-level-classes)
65 (br-find-class-name-as-list)))
66 (ch (delq nil (mapcar (function (lambda (c) (br-get-children c)))
68 (if (or ch br-show-features)
69 (br-tree-load classes)
71 (message "No descendants to display."))))
73 (defun br-tree-graph ()
74 "Start the appropriate tree application with the tree from the current listing buffer."
76 (let* ((tree) (indent) (entry) (min-indent 8000) (min-count 0)
77 (feature-match (format "^%s " br-feature-type-regexp)))
79 (goto-char (point-max))
80 (while (and (= (forward-line -1) 0)
81 (looking-at "\\([ \t]*\\)\\(.+\\)"))
82 (setq indent (br-buffer-substring (match-beginning 1) (match-end 1))
84 min-indent (cond ((= entry min-indent)
85 (setq min-count (1+ min-count))
91 entry (br-buffer-substring (match-beginning 2) (match-end 2))
92 entry (if (string-match feature-match entry)
93 (concat (char-to-string (aref entry 0))
95 "^^" (prin1-to-string (br-feature-get-tag)))
97 tree (cons (concat indent entry "\n") tree))))
99 (setq tree (cons (concat *br-tree-root-name* "\n")
101 (lambda (node) (concat " " node))) tree))))
102 (br-tree-load tree t)))
104 (defun br-tree-do-cmd (lang env cmd node)
105 ;; Load necessary Environment
106 (if (not (equal env br-env-file))
107 (let ((br (intern-soft
108 (concat lang "browse"))))
109 (if (br-in-browser) (funcall br env) (funcall br env t))))
111 (let ((hpath:display-where
112 (if (or (not (boundp 'hpath:display-where))
113 (eq hpath:display-where 'other-window))
114 'this-window ;; Force display in selected window.
115 hpath:display-where)))
116 (cond ((br-feature-tag-p node)
117 (br-feature (string-equal cmd "br-view") node))
120 ((string-equal cmd "br-view")
121 (br-view nil nil node))
122 ((string-equal cmd "br-edit")
123 (br-view nil t node))
126 (format "(OO-Browser): Illegal command: %s" cmd))))))
128 (defun br-tree-features-toggle ()
129 "Toggle between showing and hiding features when `br-tree' is invoked to display descendants graphically."
131 (setq br-show-features (not br-show-features))
132 (message "New graphical OO-Browsers will %sshow features."
133 (if br-show-features "" "not ")))
135 (defun br-tree-kill ()
136 "Kill all current graphical OO-Browser sub-processes."
138 (if (br-kill-process-group br-tree-name br-tree-num
139 "Graphical OO-Browsers")
140 (setq br-tree-num 0)))
142 (defun br-tree-load (classes-or-tree &optional tree-p)
143 "Start the appropriate tree application using trees from CLASSES-OR-TREE.
144 Optional TREE-P non-nil means CLASSES-OR-TREE is a tree ready for display."
145 (interactive (list "sClass to show descendency graph of: "))
146 (if (and br-env-file (not br-env-spec))
147 (let ((obuf (current-buffer))
148 (tree-file (expand-file-name
150 (user-real-login-name)
151 (setq br-tree-num (1+ br-tree-num)))
152 (br-temp-directory))))
154 (progn (find-file tree-file)
156 (setq buffer-read-only nil)
158 ;; Start file with Envir file name
159 (insert "^^" br-lang-prefix "^^" br-env-file "\n")
161 (mapcar 'insert classes-or-tree)
162 (br-tree-build classes-or-tree))
163 (untabify 1 (point-max))
165 (kill-buffer (current-buffer))
166 (switch-to-buffer obuf)
167 (if (memq window-system '(x mswindows win32 w32 pm))
168 (br-tree-x-load-tree-file tree-file)
169 (br-tree-nx-load-tree-file tree-file)))))))
171 (defun br-tree-nx-load-tree-file (tree-file)
172 "Load a pre-written TREE-FILE and display it in an X OO-Browser."
173 (setq delete-exited-processes t)
174 (let ((proc (get-process br-tree-name)))
175 (if (and proc (eq (process-status proc) 'run)) ;; existing tree browser
176 ;; Send it an open file command.
177 (call-process "open" nil 0 nil "-a"
178 (file-name-nondirectory *br-tree-prog-name*)
180 (let ((default-directory (file-name-as-directory
181 (expand-file-name "tree-nx" br-directory))))
182 (setq proc (start-process
183 br-tree-name nil *br-tree-prog-name*
186 (progn (set-process-filter proc 'br-tree-filter)
187 (process-kill-without-query proc)
190 (defun br-tree-x-load-tree-file (tree-file)
191 "Load a pre-written TREE-FILE and display it in an X OO-Browser."
192 (setq delete-exited-processes t)
194 (windowed-process-io t))
195 (setq proc (start-process
196 (concat br-tree-name (int-to-string br-tree-num))
201 (progn (set-process-filter proc 'br-tree-filter)
202 (process-kill-without-query proc)))))
204 ;;; ************************************************************************
205 ;;; Private functions
206 ;;; ************************************************************************
208 (defconst *br-tree-root-name* "NO-ROOT"
209 "Name to give root tree node when graph with no root is used as input.")
211 (defun br-tree-build (class-list &optional indent offset)
212 "Insert descendant trees starting with classes from CLASS-LIST.
213 Indent each class in CLASS-LIST by optional INDENT spaces (default is 0 in
214 order to ensure proper initialization). Offset each child level by optional
215 OFFSET spaces from its parent (which must be greater than zero, default 2)."
216 (or indent (setq indent 0))
217 (or offset (setq offset 2))
218 (let ((prev-expansion-str " ...")
221 (progn (setq br-tmp-class-set nil)
222 (if (= (length class-list) 1)
224 (insert *br-tree-root-name* "\n")
225 (setq indent offset))))
229 (mapcar (function (lambda (c)
230 (setq expand-subtree (br-set-cons br-tmp-class-set c)
231 ch (if expand-subtree (br-get-children c)))
234 (and (not expand-subtree)
235 (br-has-children-p c)
236 (insert prev-expansion-str))
238 (if (and br-show-features
239 (br-tree-build-features
240 c expand-subtree (+ indent offset) offset))
243 (br-tree-build ch (+ indent offset) offset)))))
245 (if (= indent 0) (setq br-tmp-class-set nil)))
247 (defun br-tree-build-features (c expand-subtree indent offset)
248 "Each language under which this function is called must define its own
249 version of `br-feature-signature-to-name'."
250 (let ((feature-list) (ch))
255 (lambda (feature-tag)
256 (concat (br-feature-signature-to-name feature-tag nil t)
257 "^^" (prin1-to-string feature-tag))))
258 (br-list-features c)))
264 (insert feature "\n")))
266 (if (setq ch (if expand-subtree (br-get-children c)))
267 (br-tree-build ch indent offset))
270 (defun br-tree-filter (process output-str)
276 (if (not (string-match "\n" output-str))
277 (setq br-cmd-str (concat br-cmd-str output-str))
278 (setq br-cmd-str (concat br-cmd-str
279 (substring output-str 0 (match-beginning 0))))
280 (if (and (> (length br-cmd-str) 9)
281 (equal (substring br-cmd-str -4)
283 (setq br-cmd-str (substring br-cmd-str 0 -4)))
284 ;; Is a command only if starts with ^^
285 (if (and (> (length br-cmd-str) 1)
286 (equal (substring br-cmd-str 0 2) "^^")
288 "^\\^\\^\\(.+\\)\\^\\^\\(.+\\)\\^\\^\\(.+\\)\\^\\^\\(.+\\)"
291 (setq lang-prefix (substring br-cmd-str
292 (+ (match-beginning 1) 2)
294 env-name (substring br-cmd-str
297 cmd-name (substring br-cmd-str
300 node (substring br-cmd-str
305 ;; `node' is either a class name or a feature-tag that we
306 ;; must convert from string format.
307 (setq feature-tag (car (read-from-string node)))
308 (if (br-feature-tag-p feature-tag)
309 (setq node feature-tag))
310 (br-tree-do-cmd lang-prefix env-name
313 (message "`%s': invalid command from the graphical OO-Browser"
315 (setq br-cmd-str nil)))))
318 ;;; ************************************************************************
319 ;;; Private functions
320 ;;; ************************************************************************
323 (defvar br-cmd-str nil
324 "Command string sent from graphical OO-Browser to the textual OO-Browser.")
326 (defvar br-show-features nil
327 "Non-nil means add features as child nodes in each graphical descendancy view.
330 (defvar br-tree-num 0)
331 (defvar br-tree-name "OO-Browser")