|
0
|
1 ;;!emacs
|
|
|
2 ;;
|
|
|
3 ;; FILE: br-tree.el
|
|
|
4 ;; SUMMARY: Interface between textual and graphical OO-Browsers.
|
|
|
5 ;; USAGE: GNU Emacs Lisp Library
|
|
|
6 ;; KEYWORDS: mouse, oop, tools
|
|
|
7 ;;
|
|
|
8 ;; AUTHOR: Bob Weiner
|
|
100
|
9 ;; ORG: InfoDock Associates
|
|
0
|
10 ;;
|
|
|
11 ;; ORIG-DATE: 12-Oct-90
|
|
100
|
12 ;; LAST-MOD: 20-Feb-97 at 07:01:02 by Bob Weiner
|
|
0
|
13 ;;
|
|
100
|
14 ;; Copyright (C) 1990-1995, 1997 Free Software Foundation, Inc.
|
|
0
|
15 ;; See the file BR-COPY for license information.
|
|
|
16 ;;
|
|
|
17 ;; This file is part of the OO-Browser.
|
|
|
18 ;;
|
|
|
19 ;; DESCRIPTION:
|
|
|
20 ;;
|
|
|
21 ;; Requires the X Window system Version 11 or NEXTSTEP.
|
|
|
22 ;;
|
|
|
23 ;; DESCRIP-END.
|
|
|
24
|
|
|
25 ;;; ************************************************************************
|
|
|
26 ;;; Other required Elisp libraries
|
|
|
27 ;;; ************************************************************************
|
|
|
28
|
|
|
29 (require 'br-lib)
|
|
|
30
|
|
|
31 ;;; ************************************************************************
|
|
|
32 ;;; Public variables
|
|
|
33 ;;; ************************************************************************
|
|
|
34
|
|
|
35 (defvar *br-tree-prog-name*
|
|
|
36 (if (or (eq window-system 'x) (null window-system))
|
|
|
37 "xoobr"
|
|
|
38 "./TreeView.app/TreeView")
|
|
|
39 "Program to run for hierarchical display of classes.")
|
|
|
40
|
|
|
41 ;;; ************************************************************************
|
|
|
42 ;;; Public functions
|
|
|
43 ;;; ************************************************************************
|
|
|
44
|
|
|
45 (defun br-tree (&optional arg)
|
|
|
46 "Start the appropriate tree application with descendency tree of current class.
|
|
|
47 With optional prefix ARG, a descendency tree for each class in current buffer."
|
|
|
48 (interactive "P")
|
|
|
49 (let* ((classes (if arg
|
|
|
50 (br-this-level-classes)
|
|
|
51 (list (br-find-class-name))))
|
|
|
52 (ch (delq nil (mapcar (function (lambda (c) (br-get-children c)))
|
|
|
53 classes))))
|
|
|
54 (if (or ch br-show-features)
|
|
|
55 (br-tree-load classes)
|
|
|
56 (beep)
|
|
|
57 (message "No descendants to display."))))
|
|
|
58
|
|
|
59 (defun br-tree-graph ()
|
|
|
60 "Start the appropriate tree application with the tree from current listing buffer."
|
|
|
61 (interactive)
|
|
|
62 (let* ((tree) (indent) (entry) (min-indent 8000) (min-count 0)
|
|
|
63 (feature-match (format "^%s " br-feature-type-regexp)))
|
|
|
64 (save-excursion
|
|
|
65 (goto-char (point-max))
|
|
|
66 (while (and (= (forward-line -1) 0)
|
|
|
67 (looking-at "\\([ \t]*\\)\\(.+\\)"))
|
|
|
68 (setq indent (buffer-substring (match-beginning 1) (match-end 1))
|
|
|
69 entry (length indent)
|
|
|
70 min-indent (cond ((= entry min-indent)
|
|
|
71 (setq min-count (1+ min-count))
|
|
|
72 entry)
|
|
|
73 ((< entry min-indent)
|
|
|
74 (setq min-count 1)
|
|
|
75 entry)
|
|
|
76 (min-indent))
|
|
|
77 entry (buffer-substring (match-beginning 2) (match-end 2))
|
|
|
78 entry (if (string-match feature-match entry)
|
|
|
79 (concat (char-to-string (aref entry 0))
|
|
|
80 (substring entry 2)
|
|
|
81 "^^" (br-feature-get-signature))
|
|
|
82 entry)
|
|
|
83 tree (cons (concat indent entry "\n") tree))))
|
|
|
84 (or (= min-count 1)
|
|
|
85 (setq tree (cons (concat *br-tree-root-name* "\n")
|
|
|
86 (mapcar (function
|
|
|
87 (lambda (node) (concat " " node))) tree))))
|
|
|
88 (br-tree-load tree t)))
|
|
|
89
|
|
|
90 (defun br-tree-do-cmd (lang env cmd node)
|
|
|
91 ;; Load necessary Environment
|
|
|
92 (if (not (equal env br-env-file))
|
|
|
93 (let ((br (intern-soft
|
|
|
94 (concat lang "browse"))))
|
|
|
95 (if (br-in-browser) (funcall br env) (funcall br env t))))
|
|
|
96 ;; Do command
|
|
|
97 (cond ((and (not (eq (symbol-function 'br-feature-tree-command-p)
|
|
|
98 'br-undefined-function))
|
|
|
99 (br-feature-tree-command-p node)))
|
|
|
100 ((string-equal cmd "br-view")
|
|
|
101 (br-view nil nil node))
|
|
|
102 ((string-equal cmd "br-edit")
|
|
|
103 (br-view nil t node))
|
|
|
104 (t (beep)
|
|
|
105 (message
|
|
|
106 (format "(OO-Browser): Illegal command: %s" cmd)))))
|
|
|
107
|
|
|
108 (defun br-tree-features-toggle ()
|
|
100
|
109 "Toggle between showing and hiding features when `br-tree' is invoked to display descendants graphically."
|
|
0
|
110 (interactive)
|
|
|
111 (setq br-show-features (not br-show-features))
|
|
|
112 (message "New graphical OO-Browsers will %sshow features."
|
|
|
113 (if br-show-features "" "not ")))
|
|
|
114
|
|
|
115 (defun br-tree-kill ()
|
|
100
|
116 "Kill all current `Tree' sub-processes."
|
|
0
|
117 (interactive)
|
|
|
118 (if (br-kill-process-group br-tree-name br-tree-num
|
|
|
119 "Tree displays")
|
|
|
120 (setq br-tree-num 0)))
|
|
|
121
|
|
|
122 (defun br-tree-load (classes-or-tree &optional tree-p)
|
|
|
123 "Start the appropriate tree application using trees from CLASSES-OR-TREE.
|
|
|
124 Optional TREE-P non-nil means CLASSES-OR-TREE is a tree ready for display."
|
|
|
125 (interactive (list "sClass to show descendency graph of: "))
|
|
|
126 (if (and br-env-file (not br-env-spec))
|
|
|
127 (let ((obuf (current-buffer))
|
|
|
128 (tree-file (concat "/tmp/br-" (user-real-login-name)
|
|
|
129 (int-to-string
|
|
|
130 (setq br-tree-num (1+ br-tree-num)))
|
|
|
131 ".tree")))
|
|
|
132 (if classes-or-tree
|
|
|
133 (progn (find-file tree-file)
|
|
|
134 (widen)
|
|
|
135 (setq buffer-read-only nil)
|
|
|
136 (erase-buffer)
|
|
|
137 ;; Start file with Envir file name
|
|
|
138 (insert "^^" br-lang-prefix "^^" br-env-file "\n")
|
|
|
139 (if tree-p
|
|
|
140 (mapcar 'insert classes-or-tree)
|
|
|
141 (br-tree-build classes-or-tree))
|
|
|
142 (untabify 1 (point-max))
|
|
|
143 (save-buffer)
|
|
|
144 (kill-buffer (current-buffer))
|
|
|
145 (switch-to-buffer obuf)
|
|
|
146 (if (eq window-system 'x)
|
|
|
147 (br-tree-x-load-tree-file tree-file)
|
|
|
148 (br-tree-nx-load-tree-file tree-file)))))))
|
|
|
149
|
|
|
150 (defun br-tree-nx-load-tree-file (tree-file)
|
|
|
151 "Load a pre-written TREE-FILE and display it in an X OO-Browser."
|
|
|
152 (setq delete-exited-processes t)
|
|
|
153 (let ((proc (get-process br-tree-name)))
|
|
|
154 (if (and proc (eq (process-status proc) 'run)) ;; existing tree browser
|
|
|
155 ;; Send it an open file command.
|
|
|
156 (call-process "open" nil 0 nil "-a"
|
|
|
157 (file-name-nondirectory *br-tree-prog-name*)
|
|
|
158 tree-file)
|
|
|
159 (let ((default-directory (file-name-as-directory
|
|
|
160 (expand-file-name "tree-nx" br-directory))))
|
|
|
161 (setq proc (start-process
|
|
|
162 br-tree-name nil *br-tree-prog-name*
|
|
|
163 tree-file))
|
|
|
164 (if proc
|
|
|
165 (progn (set-process-filter proc 'br-tree-filter)
|
|
|
166 (process-kill-without-query proc)
|
|
|
167 ))))))
|
|
|
168
|
|
|
169 (defun br-tree-x-load-tree-file (tree-file)
|
|
|
170 "Load a pre-written TREE-FILE and display it in an X OO-Browser."
|
|
|
171 (setq delete-exited-processes t)
|
|
|
172 (let ((proc))
|
|
|
173 (setq proc (start-process
|
|
|
174 (concat br-tree-name (int-to-string br-tree-num))
|
|
|
175 nil
|
|
|
176 *br-tree-prog-name*
|
|
|
177 tree-file))
|
|
|
178 (if proc
|
|
|
179 (progn (set-process-filter proc 'br-tree-filter)
|
|
|
180 (process-kill-without-query proc)))))
|
|
|
181
|
|
|
182 ;;; ************************************************************************
|
|
|
183 ;;; Private functions
|
|
|
184 ;;; ************************************************************************
|
|
|
185
|
|
|
186 (defconst *br-tree-root-name* "NO-ROOT"
|
|
|
187 "Name to give root tree node when graph with no root is used as input.")
|
|
|
188
|
|
|
189 (defun br-tree-build (class-list &optional indent offset)
|
|
|
190 "Insert descendant trees starting with classes from CLASS-LIST.
|
|
|
191 Indent each class in CLASS-LIST by optional INDENT spaces (default is 0 in
|
|
|
192 order to ensure proper initialization). Offset each child level by optional
|
|
|
193 OFFSET spaces from its parent (which must be greater than zero, default 2)."
|
|
|
194 (or indent (setq indent 0))
|
|
|
195 (or offset (setq offset 2))
|
|
|
196 (let ((prev-expansion-str " ...")
|
|
|
197 ch expand-subtree)
|
|
|
198 (if (= indent 0)
|
|
|
199 (progn (setq br-tmp-class-set nil)
|
|
|
200 (if (= (length class-list) 1)
|
|
|
201 nil
|
|
|
202 (insert *br-tree-root-name* "\n")
|
|
|
203 (setq indent offset))))
|
|
|
204 (if class-list
|
|
|
205 (progn
|
|
|
206 (indent-to indent)
|
|
|
207 (mapcar (function (lambda (c)
|
|
|
208 (setq expand-subtree (br-set-cons br-tmp-class-set c)
|
|
|
209 ch (if expand-subtree (br-get-children c)))
|
|
|
210 (indent-to indent)
|
|
|
211 (insert c)
|
|
|
212 (and (not expand-subtree)
|
|
|
213 (br-has-children-p c)
|
|
|
214 (insert prev-expansion-str))
|
|
|
215 (insert "\n")
|
|
|
216 (if (and br-show-features
|
|
|
217 (br-tree-build-features
|
|
|
218 c expand-subtree (+ indent offset) offset))
|
|
|
219 nil
|
|
|
220 (if ch
|
|
|
221 (br-tree-build ch (+ indent offset) offset)))))
|
|
|
222 class-list))))
|
|
|
223 (if (= indent 0) (setq br-tmp-class-set nil)))
|
|
|
224
|
|
|
225 (defun br-tree-build-features (c expand-subtree indent offset)
|
|
|
226 "Each language under which this function is called must define its own
|
|
100
|
227 version of `br-list-features' and `br-feature-signature-to-name'."
|
|
0
|
228 (let ((features) (ch))
|
|
|
229 (and expand-subtree
|
|
|
230 (setq features
|
|
|
231 (mapcar
|
|
|
232 (function
|
|
|
233 (lambda (feature-tag)
|
|
|
234 (concat (br-feature-signature-to-name feature-tag nil t)
|
|
|
235 "^^" feature-tag)))
|
|
|
236 (br-list-features c)))
|
|
|
237 (progn
|
|
|
238 (mapcar
|
|
|
239 (function
|
|
|
240 (lambda (feature)
|
|
|
241 (indent-to indent)
|
|
|
242 (insert feature "\n")))
|
|
|
243 features)
|
|
|
244 (if (setq ch (if expand-subtree (br-get-children c)))
|
|
|
245 (br-tree-build ch indent offset))
|
|
|
246 t))))
|
|
|
247
|
|
|
248 (defun br-tree-filter (process output-str)
|
|
|
249 (let ((br-lang-px)
|
|
|
250 (br-env-nm)
|
|
|
251 (br-cmd-nm)
|
|
|
252 (br-node-nm))
|
|
|
253 (if (not (string-match "\n" output-str))
|
|
|
254 (setq br-cmd-str (concat br-cmd-str output-str))
|
|
|
255 (setq br-cmd-str (concat br-cmd-str
|
|
|
256 (substring output-str 0 (match-beginning 0))))
|
|
|
257 (if (and (> (length br-cmd-str) 9)
|
|
|
258 (equal (substring br-cmd-str -4)
|
|
|
259 " ..."))
|
|
|
260 (setq br-cmd-str (substring br-cmd-str 0 -4)))
|
|
|
261 ;; Is a command only if starts with ^^
|
|
|
262 (if (and (> (length br-cmd-str) 1)
|
|
|
263 (equal (substring br-cmd-str 0 2) "^^")
|
|
|
264 (string-match
|
|
|
265 "^^^\\(.+\\)^^\\(.+\\)^^\\(.+\\)^^\\(.+\\)"
|
|
|
266 br-cmd-str))
|
|
|
267 (progn
|
|
|
268 (setq br-lang-px (substring br-cmd-str
|
|
|
269 (+ (match-beginning 1) 2)
|
|
|
270 (match-end 1))
|
|
|
271 br-env-nm (substring br-cmd-str
|
|
|
272 (match-beginning 2)
|
|
|
273 (match-end 2))
|
|
|
274 br-cmd-nm (substring br-cmd-str
|
|
|
275 (match-beginning 3)
|
|
|
276 (match-end 3))
|
|
|
277 br-node-nm (substring br-cmd-str
|
|
|
278 (match-beginning 4)
|
|
|
279 (match-end 4))
|
|
|
280 br-cmd-str nil)
|
|
|
281 (br-tree-do-cmd br-lang-px br-env-nm
|
|
|
282 br-cmd-nm br-node-nm))
|
|
|
283 (beep)
|
|
100
|
284 (message "`%s': invalid command from graphical browser"
|
|
0
|
285 br-cmd-str)
|
|
|
286 (setq br-cmd-str nil)))))
|
|
|
287
|
|
|
288
|
|
|
289 ;;; ************************************************************************
|
|
|
290 ;;; Private functions
|
|
|
291 ;;; ************************************************************************
|
|
|
292
|
|
|
293
|
|
|
294 (defvar br-cmd-str nil
|
|
|
295 "Command string sent from graphical OO-Browser to the textual OO-Browser.")
|
|
|
296
|
|
|
297 (defvar br-show-features nil
|
|
|
298 "Non-nil means add features as child nodes in each graphical descendancy view.")
|
|
|
299
|
|
|
300 (defvar br-tree-num 0)
|
|
|
301 (defvar br-tree-name "Tree")
|
|
|
302
|
|
|
303 (provide 'br-tree)
|
