Mercurial > hg > xemacs-beta

comparison lisp/oobr/br-tree.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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-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
9 ;; ORG: Motorola Inc.
10 ;;
11 ;; ORIG-DATE: 12-Oct-90
12 ;; LAST-MOD: 5-Jun-95 at 12:00:10 by Bob Weiner
13 ;;
14 ;; Copyright (C) 1990-1995 Free Software Foundation, Inc.
15 ;; See the file BR-COPY for license information.
16 ;;
17 ;; This file is part of the OO-Browser.
18 ;;
19 ;; 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 ()
109 "Toggle between showing and hiding features when 'br-tree' is invoked to display descendants graphically."
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 ()
116 "Kill all current 'Tree' sub-processes."
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
227 version of 'br-list-features' and 'br-feature-signature-to-name'."
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)
284 (message "'%s': invalid command from graphical browser"
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)