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

   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:          BeOpen.com
  10 ;;
  11 ;; ORIG-DATE:    12-Oct-90
  12 ;; LAST-MOD:      9-Jun-99 at 18:05:26 by Bob Weiner
  13 ;;
  14 ;; Copyright (C) 1990-1995, 1997, 1998  BeOpen.com
  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, Windows 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   (let* ((prog
  37           (cond ((or (eq window-system 'x)
  38                      (null window-system))
  39                  "xoobr")
  40                 ;; Windows
  41                 ((memq window-system '(mswindows win32 w32 pm)) "oobr.exe")
  42                 ;; NeXTSTEP
  43                 (t "TreeView")))
  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)))
  50         gui-oo-browser
  51       prog))
  52   "Program to run for hierarchical display of classes.")
  53
  54 ;;; ************************************************************************
  55 ;;; Public functions
  56 ;;; ************************************************************************
  57
  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."
  62   (interactive "P")
  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)))
  67                               classes))))
  68     (if (or ch br-show-features)
  69         (br-tree-load classes)
  70       (beep)
  71       (message "No descendants to display."))))
  72
  73 (defun br-tree-graph ()
  74   "Start the appropriate tree application with the tree from the current listing buffer."
  75   (interactive)
  76   (let* ((tree) (indent) (entry) (min-indent 8000) (min-count 0)
  77          (feature-match (format "^%s " br-feature-type-regexp)))
  78     (save-excursion
  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))
  83               entry (length indent)
  84               min-indent (cond ((= entry min-indent)
  85                                 (setq min-count (1+ min-count))
  86                                 entry)
  87                                ((< entry min-indent)
  88                                 (setq min-count 1)
  89                                 entry)
  90                                (min-indent))
  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))
  94                                 (substring entry 2)
  95                                 "^^" (prin1-to-string (br-feature-get-tag)))
  96                       entry)
  97               tree (cons (concat indent entry "\n") tree))))
  98     (or (= min-count 1)
  99         (setq tree (cons (concat *br-tree-root-name* "\n")
 100                          (mapcar (function
 101                                   (lambda (node) (concat "  " node))) tree))))
 102     (br-tree-load tree t)))
 103
 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))))
 110   ;; Do command
 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))
 118           ;;
 119           ;; node = class name
 120           ((string-equal cmd "br-view")
 121            (br-view nil nil node))
 122           ((string-equal cmd "br-edit")
 123            (br-view nil t node))
 124           (t (beep)
 125              (message
 126               (format "(OO-Browser):  Illegal command: %s" cmd))))))
 127
 128 (defun br-tree-features-toggle ()
 129   "Toggle between showing and hiding features when `br-tree' is invoked to display descendants graphically."
 130   (interactive)
 131   (setq br-show-features (not br-show-features))
 132   (message "New graphical OO-Browsers will %sshow features."
 133            (if br-show-features "" "not ")))
 134
 135 (defun br-tree-kill ()
 136   "Kill all current graphical OO-Browser sub-processes."
 137   (interactive)
 138   (if (br-kill-process-group br-tree-name br-tree-num
 139                              "Graphical OO-Browsers")
 140       (setq br-tree-num 0)))
 141
 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
 149                         (format "%s%d.obr"
 150                                 (user-real-login-name)
 151                                 (setq br-tree-num (1+ br-tree-num)))
 152                         (br-temp-directory))))
 153         (if classes-or-tree
 154             (progn (find-file tree-file)
 155                    (widen)
 156                    (setq buffer-read-only nil)
 157                    (erase-buffer)
 158                    ;; Start file with Envir file name
 159                    (insert "^^" br-lang-prefix "^^" br-env-file "\n")
 160                    (if tree-p
 161                        (mapcar 'insert classes-or-tree)
 162                      (br-tree-build classes-or-tree))
 163                    (untabify 1 (point-max))
 164                    (save-buffer)
 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)))))))
 170
 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*)
 179                       tree-file)
 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*
 184                      tree-file))
 185         (if proc
 186             (progn (set-process-filter proc 'br-tree-filter)
 187                    (process-kill-without-query proc)
 188                    ))))))
 189
 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)
 193   (let ((proc)
 194         (windowed-process-io t))
 195     (setq proc (start-process
 196                 (concat br-tree-name (int-to-string br-tree-num))
 197                 nil
 198                 *br-tree-prog-name*
 199                 tree-file))
 200     (if proc
 201         (progn (set-process-filter proc 'br-tree-filter)
 202                (process-kill-without-query proc)))))
 203
 204 ;;; ************************************************************************
 205 ;;; Private functions
 206 ;;; ************************************************************************
 207
 208 (defconst *br-tree-root-name* "NO-ROOT"
 209   "Name to give root tree node when graph with no root is used as input.")
 210
 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 " ...")
 219         ch expand-subtree)
 220     (if (= indent 0)
 221         (progn (setq br-tmp-class-set nil)
 222                (if (= (length class-list) 1)
 223                    nil
 224                  (insert *br-tree-root-name* "\n")
 225                  (setq indent offset))))
 226     (if class-list
 227         (progn
 228           (indent-to indent)
 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)))
 232                      (indent-to indent)
 233                      (insert c)
 234                      (and (not expand-subtree)
 235                           (br-has-children-p c)
 236                           (insert prev-expansion-str))
 237                      (insert "\n")
 238                      (if (and br-show-features
 239                               (br-tree-build-features
 240                                c expand-subtree (+ indent offset) offset))
 241                          nil
 242                        (if ch
 243                            (br-tree-build ch (+ indent offset) offset)))))
 244                   class-list))))
 245   (if (= indent 0) (setq br-tmp-class-set nil)))
 246
 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))
 251     (and expand-subtree
 252          (setq feature-list
 253                (mapcar
 254                 (function
 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)))
 259          (progn
 260            (mapcar
 261             (function
 262              (lambda (feature)
 263                (indent-to indent)
 264                (insert feature "\n")))
 265             feature-list)
 266            (if (setq ch (if expand-subtree (br-get-children c)))
 267                (br-tree-build ch indent offset))
 268            t))))
 269
 270 (defun br-tree-filter (process output-str)
 271   (let ((lang-prefix)
 272         (env-name)
 273         (cmd-name)
 274         (node)
 275         (feature-tag))
 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)
 282                       " ..."))
 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) "^^")
 287                (string-match
 288                 "^\\^\\^\\(.+\\)\\^\\^\\(.+\\)\\^\\^\\(.+\\)\\^\\^\\(.+\\)"
 289                 br-cmd-str))
 290           (progn
 291             (setq lang-prefix (substring br-cmd-str
 292                                          (+ (match-beginning 1) 2)
 293                                          (match-end 1))
 294                   env-name (substring br-cmd-str
 295                                       (match-beginning 2)
 296                                       (match-end 2))
 297                   cmd-name (substring br-cmd-str
 298                                       (match-beginning 3)
 299                                       (match-end 3))
 300                   node (substring br-cmd-str
 301                                   (match-beginning 4)
 302                                   (match-end 4))
 303                   br-cmd-str nil)
 304             ;;
 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
 311                             cmd-name node))
 312         (beep)
 313         (message "`%s': invalid command from the graphical OO-Browser"
 314                  br-cmd-str)
 315         (setq br-cmd-str nil)))))
 316
 317
 318 ;;; ************************************************************************
 319 ;;; Private functions
 320 ;;; ************************************************************************
 321
 322
 323 (defvar br-cmd-str nil
 324   "Command string sent from graphical OO-Browser to the textual OO-Browser.")
 325
 326 (defvar br-show-features nil
 327   "Non-nil means add features as child nodes in each graphical descendancy view.
 328 Defaults to nil.")
 329
 330 (defvar br-tree-num 0)
 331 (defvar br-tree-name "OO-Browser")
 332
 333 (provide 'br-tree)