home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 5 Edit
/
05-Edit.zip
/
browser2.zip
/
br-tree.el
< prev
next >
Wrap
Lisp/Scheme
|
1995-02-17
|
36KB
|
1,099 lines
;;; CLASS BROWSER FOR C++
;;; $Id: br-tree.el,v 3.1 1995/02/17 18:19:36 mmann Exp $
;;;
;;; **********************************************************************
;;; Copyright (C) 1993, 1994 Gerd Moellmann. All rights reserved.
;;; Altenbergstr. 6, D-40235 Duesseldorf, Germany
;;; 100025.3303@COMPUSERVE.COM
;;; Suggestions, comments and requests for improvements are welcome.
;;; **********************************************************************
;;;
;;; This version works with both Emacs version 18 and 19, and I want
;;; to keep it that way. It requires the CL-19 Common Lisp compatibility
;;; package for Emacs 18 and 19.
;;;
;;; This file contains the functins for TREE-MODE.
;;;
;; This code is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY. No author or distributor
;; accepts responsibility to anyone for the consequences of using it
;; or for whether it serves any particular purpose or works at all,
;; unless he says so in writing. Refer to the GNU Emacs General Public
;; License for full details.
;; Everyone is granted permission to copy, modify and redistribute
;; this code, but only under the conditions described in the
;; GNU Emacs General Public License. A copy of this license is
;; supposed to have been given to you along with GNU Emacs so you
;; can know your rights and responsibilities. It should be in a
;; file named COPYING. Among other things, the copyright notice
;; and this notice must be preserved on all copies.
(require 'cl-19 "cl")
(require 'backquote)
(require 'br-struc)
(require 'br-macro)
;;;
;;; Temporary used to communicate with browse-view/find.
;;; Contains (TREE-HEADER TREE-OR-MEMBER MEMBER-LIST)
;;;
(defvar browse-position-to-view nil)
(defvar browse-info-to-view nil)
(defvar tree-mode-hook nil
"Run in each new tree buffer.")
(defvar tree-mark-face 'red
"The face used for the mark character in the tree.")
(defvar tree-root-class-face 'purple
"The face used for root classes in the tree.")
(defvar tree-multiply-derived-face 'red
"The face for classes that have more than one base class.")
(defvar tree-filename-face 'ForestGreen
"The color for filenames displayed in the tree.")
(defvar tree-normal-face 'default
"Face for everything else in the tree.")
(defconst tree-buffer-name "*Tree*"
"The name of the buffer containing the class tree.")
(defvar @indentation 2
"The amount by which subclasses will be indented relative
to their superclasses in the class tree.")
(defvar tree-source-file-column 40
"The column in which source file names are displayed in the tree
buffer.")
(defvar tree-mode-map ()
"The keymap used in tree mode buffers.")
(defvar tree-left-margin 2
"*Amount of space left at the left side of the tree display. This space
is used to display markers.")
(defun tree-make-face (face)
(when (and window-system (browse-emacs-19-p))
(unless (memq face (face-list))
(set-face-foreground (make-face face) (symbol-name face)))))
(tree-make-face tree-root-class-face)
(tree-make-face tree-mark-face)
(tree-make-face tree-multiply-derived-face)
(tree-make-face tree-filename-face)
;;;
;;; Return T if any class in the tree contained in the current buffer
;;; is marked.
;;;
(defun* tree-marked-exist-p ()
(dotrees (tree @tree-obarray)
(when (tree-mark tree)
(return-from tree-marked-exist-p tree))))
;;;
;;; Create a new tree buffer for tree TREE which was loaded from file
;;; TAGS-FILE. HEADER is the header structure of the file. OBARRAY is
;;; an obarray with a symbol for each class in the tree.
;;; FIND-FILE-BUFFER if non-nil is the buffer from which the Lisp data
;;; was read. Return the buffer created.
;;;
(defun* tree-create-buffer (tree tags-file header obarray pop
&optional find-file-buffer
&aux name)
(cond (find-file-buffer
(set-buffer find-file-buffer)
(erase-buffer)
(setq name (tree-frozen-buffer-name tags-file))
(browse-rename-buffer-safe name))
(t
(setq name tree-buffer-name)
(set-buffer (get-buffer-create name))))
;; Switch to tree mode and initialize buffer local variables.
(tree-mode)
(setf @tree tree
@tags-filename tags-file
@tree-obarray obarray
@header header
@frozen (not (null find-file-buffer)))
;; Create obarray of all members for fast member lookup.
(when (and browse-fast-member-lookup
(not browse-lazy-fast-members))
(tree-fill-member-obarray))
;; Switch or pop to the tree buffer; display the tree and return the
;; buffer.
(case pop
(switch (switch-to-buffer name))
(pop (pop-to-buffer name)))
(tree-redisplay)
(set-buffer-modified-p nil)
(current-buffer))
;;;
;;; Initialize keymap.
;;;
(unless tree-mode-map
(setf tree-mode-map (make-keymap))
(suppress-keymap tree-mode-map)
(when (and (browse-emacs-19-p) window-system)
(define-key tree-mode-map [mouse-2] 'tree-mouse-2)
(define-key tree-mode-map [down-mouse-1] 'tree-mouse-1))
(define-key tree-mode-map "a" 'tree-show-vars)
(define-key tree-mode-map "c" 'tree-window-configuration)
(define-key tree-mode-map "f" 'tree-find-source)
(define-key tree-mode-map "g" 'tree-position-on-class)
(define-key tree-mode-map "l" 'tree-redisplay)
(define-key tree-mode-map "m" 'tree-toggle-mark)
(define-key tree-mode-map "p" 'tree-show-fns)
(define-key tree-mode-map "q" 'bury-buffer)
(define-key tree-mode-map "r" 'tree-show-revision)
(define-key tree-mode-map "S" 'tree-toggle-filenames)
(define-key tree-mode-map "s" 'tree-show-single-filename)
(define-key tree-mode-map "t" 'tree-show-types)
(define-key tree-mode-map "u" 'tree-unmark)
(define-key tree-mode-map "v" 'tree-view-source)
(define-key tree-mode-map "w" 'tree-set-indentation)
(define-key tree-mode-map "x" 'tree-statistics)
(define-key tree-mode-map "A" 'tree-show-svars)
(define-key tree-mode-map "P" 'tree-show-sfns)
(define-key tree-mode-map "F" 'tree-show-friends)
(define-key tree-mode-map "\C-d" 'tree-kill-class)
(define-key tree-mode-map "\C-i" 'tree-pop-to-members)
(define-key tree-mode-map "\C-m" 'tree-find-source)
(define-key tree-mode-map "*" 'tree-expand-all)
(define-key tree-mode-map "+" 'tree-expand-branch)
(define-key tree-mode-map "-" 'tree-collapse-branch)
(define-key tree-mode-map "/" 'tree-position-on-class)
(define-key tree-mode-map " " 'tree-view-source)
(define-key tree-mode-map "." 'browse-repeat-search)
(define-key tree-mode-map "?" 'describe-mode))
;;;###autoload
(defun tree-mode ()
"Major mode for tree buffers. Each line corresponds to a class in a
class tree. Letters do not insert themselves, they are commands,
instead. File operations in the tree buffer work on trees. E.g.,
\\[save-buffer] writes the tree to the file it was loaded from.
\\<tree-mode-map>
\\[tree-show-vars] -- show instance member variables.
\\[tree-show-svars] -- show static member variables.
\\[tree-window-configuration] -- restore window configuration (Emacs 18).
\\[tree-find-source] -- find the file containing the class declaration.
\\[tree-show-friends] -- display the list of friend functions of the class.
\\[tree-position-on-class] -- position point on a class read from minibuffer.
\\[tree-redisplay] -- redisplay the class tree.
\\[tree-toggle-mark] -- mark/ unmark the class(es) point is on.
\\[tree-show-fns] -- display the list of member functions.
\\[tree-show-sfns] -- display the list of static member functions.
\\[bury-buffer] -- bury the tree buffer.
\\[tree-show-revision] -- show current browser revision level.
\\[tree-show-single-filename] -- display source file for current line.
\\[tree-toggle-filenames] -- toggle file name display.
\\[tree-show-types] -- display the list of nested types.
\\[tree-unmark] -- unmark, with prefix arg mark, all classes in the tree.
\\[tree-view-source] -- view the source file containing the class declaration.
\\[tree-set-indentation] -- set the indentation with of the tree.
\\[tree-statistics] -- display statistics for the tree.
\\[tree-expand-all] -- expand all collapsed branches of the tree.
\\[tree-expand-branch] -- expand a single branch in the tree.
\\[tree-collapse-branch] -- collapse a branch in the tree.
\\[browse-repeat-search] -- repeat the last search performed.
\\[describe-mode] -- describe mode.
\\[tree-kill-class] -- delete a class from the tree.
\\<global-map>
\\[save-buffer] -- write tree to file it was loaded from.
\\[write-file] -- write tree to another file.
\\[revert-buffer] -- revert tree from disk.
Tree mode key bindings:
\\{tree-mode-map}
\\<global-map>
Related global key bindings:
\\[browse-tags-apropos] -- view member matching regexp.
\\[browse-tags-back] -- go back in position stack.
\\[browse-tags-forward] -- go forward in position stack.
\\[browse-tags-list] -- list members in file.
\\[browse-tags-find-member-buffer] -- display member buffer containing member.
\\[browse-electric-position-list] -- electric position stack menu.
\\[browse-search] -- search for regexp in files mentioned in tree.
\\[browse-search-member-usage] -- search for calls of member.
\\[browse-tags-view] -- view member point is on.
\\[browse-query-replace] -- perform query replace in files.
\\[browse-tags-find] -- find member point is on.
\\[browse-loop] -- repeat last search or query replace.
\\[browse-add-region] -- add region to tree.
\\[browse-add-buffer] -- add buffer to tree."
(kill-all-local-variables)
(mapcar
'make-local-variable '(@tags-filename
@indentation @tree @header @show-filenames @frozen
@tree-obarray @mode-strings))
(use-local-map tree-mode-map)
(setf @show-filenames nil
@tree-obarray (make-vector 127 0)
@frozen nil
major-mode 'tree-mode
mode-name "C++ Tree"
mode-line-format (list "" 'mode-line-modified 'mode-name ": "
'@mode-strings "%-")
buffer-read-only t
selective-display t
selective-display-ellipses t)
(run-hooks 'tree-mode-hook))
;;;
;;; Show revision information.
;;;
(defun tree-show-revision ()
(interactive)
(message "BROWSE v%s. %s" (browse-revision) (browse-copyright)))
;;;
;;; Remove the class point is on from the class tree.
;;;
(defun tree-kill-class (forced)
(interactive "P")
(let* ((class (tree-get-tree-at-point))
(class-name (class-name (tree-class class)))
(subclasses (tree-subclasses class)))
(cond ((or forced
(y-or-n-p (concat "Delete class " class-name "? ")))
(setf @tree (browse-remove-class @tree class))
(set-buffer-modified-p t)
(message "%s %sdeleted." class-name
(if subclasses "and derived classes " ""))
(tree-redisplay))
(t
(message "Aborted.")))))
;;;
;;; Toggle marks in the tree.
;;;
(defun tree-toggle-mark (&optional n-times)
"Toggle mark for class cursor is on. If given a numeric argument, mark
that much classes."
(interactive "p")
(let (to-change pnt)
;; Get the classes whose mark must be toggled. Note that
;; TREE-GET-TREE-AT-POINT might issue an error.
(condition-case error
(loop repeat (or n-times 1)
as tree = (tree-get-tree-at-point)
do (progn
(setf (tree-mark tree) (not (tree-mark tree)))
(forward-line 1)
(push tree to-change)))
(error nil))
;; SAVE-EXCURSION gets confused here. Instead, remember point and
;; go back there after the replacement.
(setq pnt (point))
;; For all these classes, reverse the mark char in the display
;; by a regexp replace over the whole buffer. The reason for this
;; is that classes might have multiple base classes. If this is
;; the case, they are displayed more than once in the tree.
(browse-output
(loop for tree in to-change
as regexp = (concat "^[ >][ \t]*"
(regexp-quote (class-name (tree-class tree)))
"[ \t\n\r]")
finally (goto-char pnt) do
(goto-char (point-min))
(loop while (re-search-forward regexp nil t)
do (progn
(goto-char (match-beginning 0))
(delete-char 1)
(insert-char (if (tree-mark tree) ?> ? ) 1)
(browse-put-text-property (1- (point)) (point)
'browser 'mark)
(browse-put-text-property (1- (point)) (point)
'mouse-face 'highlight)
(browse-set-face (1- (point)) (point) tree-mark-face)
(goto-char (match-end 0))))))))
;;;
;;; Mark or unmark the whole tree.
;;;
(defun tree-unmark (prefix)
"Unmark, with prefix mark, all classes in the tree."
(interactive "P")
(dotrees (tree @tree-obarray)
(setf (tree-mark tree) prefix))
(tree-redisplay-marks (point-min) (point-max)))
;;;
;;; Toggle display of filenames in the current line. This function
;;; was introduced because the filename display in Emacs 19 when
;;; highliting is used is quite slow.
;;;
(defun tree-show-single-filename (prefix)
"Show filename in the line point is in. With prefix, insert that much
filenames."
(interactive "p")
(unless @show-filenames
(browse-output
(dotimes (i prefix)
(let ((tree (tree-get-tree-at-point))
start
filename-existing)
(unless tree
return)
(beginning-of-line)
(skip-chars-forward " \t*a-zA-Z0-9_")
(setq start (point)
filename-existing (looking-at "<"))
(delete-region start (save-excursion (end-of-line) (point)))
(unless filename-existing
(browse-move-to-column tree-source-file-column)
(insert "<" (or (class-file (tree-class tree))
"unknown")
">"))
(browse-set-face start (point) tree-filename-face)
(beginning-of-line)
(forward-line 1))))))
;;;
;;; Toggle display of filenames for the whole tree.
;;;
(defun tree-toggle-filenames ()
"Toggle display of filenames in tree buffer."
(interactive)
(setf @show-filenames (not @show-filenames))
(let ((old-line (count-lines (point-min) (point))))
(tree-redisplay)
(goto-line old-line)))
;;;
;;; Some predicates on buffers.
;;;
(defun member-buffer-p (buffer)
(eq (cdr (assoc 'major-mode (buffer-local-variables buffer))) 'member-mode))
(defun tree-buffer-p (buffer)
(eq (cdr (assoc 'major-mode (buffer-local-variables buffer))) 'tree-mode))
(defun browse-buffer-p (buffer)
(memq (cdr (assoc 'major-mode (buffer-local-variables buffer)))
'(tree-mode member-mode)))
;;;
;;; Return various lists of buffers.
;;;
(defun browse-buffers ()
(delete-if-not 'browse-buffer-p (buffer-list)))
(defun member-buffers ()
(delete-if-not 'member-buffer-p (buffer-list)))
(defun tree-buffers ()
(delete-if-not 'tree-buffer-p (buffer-list)))
;;;
;;; Return the tree of a buffer
;;;
(defun tree-buffer-tree (buffer)
(browse-@value '@tree buffer))
;;;
;;; Return a list of buffers with different trees.
;;;
(defun* browse-different-tree-buffers ()
(delete-duplicates (nconc (tree-buffers) (member-buffers))
:key 'tree-buffer-tree))
;;;
;;; Return a list of members buffers displaying the same tree as
;;; the current buffer.
;;;
(defun browse-same-tree-member-buffers ()
(delete-if-not (function (lambda (b) (eq (tree-buffer-tree b) @tree)))
(member-buffers)))
;;;
;;; Pop to a member buffer.
;;;
(defun tree-pop-to-members (arg)
"Pop to the buffer displaying members (switch to buffer if
prefix arg). If no member buffer exists, make one."
(interactive "P")
(let ((buf (or (first (browse-same-tree-member-buffers))
(get-buffer member-buffer-name)
(tree-show-fns))))
(when buf
(if arg
(switch-to-buffer buf)
(pop-to-buffer buf)))
buf))
;;;
;;; Saving/ restoring the window configuration. This is for Emacs 18,
;;; only. It doesn't make much sense for Emacs 19.
;;;
(defun tree-window-configuration (arg)
"Save the current window configuration when called with
prefix. Restore window configuration without prefix."
(interactive "P")
(cond (arg
(setf browse-window-configuration (current-window-configuration)))
(browse-window-configuration
(set-window-configuration browse-window-configuration))
(t
(error "No window configuration remembered!"))))
;;;
;;; Setting the indentation width of the class tree
;;;
(defun tree-set-indentation ()
"Set the indentation width of the tree display."
(interactive)
(let ((width (string-to-int (read-from-minibuffer
(concat "Indentation ("
(int-to-string @indentation)
"): ")))))
(when (plusp width)
(setf @indentation width)
(tree-redisplay))))
;;;
;;; Display various kinds of member buffers.
;;;
(defun tree-show-vars (arg)
"Display member variables; with prefix arg in frozen member buffer."
(interactive "P")
(member-display 'tree-member-variables arg))
(defun tree-show-fns (&optional arg)
"Display member functions; with prefix arg in frozen member buffer."
(interactive "P")
(member-display 'tree-member-functions arg))
(defun tree-show-svars (arg)
"Display static member variables; with prefix arg in frozen member buffer."
(interactive "P")
(member-display 'tree-static-variables arg))
(defun tree-show-sfns (arg)
"Display static member functions; with prefix arg in frozen member buffer."
(interactive "P")
(member-display 'tree-static-functions arg))
(defun tree-show-friends (arg)
"Display friend functions; with prefix arg in frozen member buffer."
(interactive "P")
(member-display 'tree-friends arg))
(defun tree-show-types (arg)
"Display types defined in a class; with prefix arg in frozen member buffer."
(interactive "P")
(member-display 'tree-types arg))
;;;
;;; Finding or viewing a class.
;;;
(defun tree-find-source ()
"Find the file containing the class' declaration and position
cursor on it."
(interactive)
(tree-goto-class nil))
;;;
;;; View the file contaiing the class' declaration.
;;;
(defun tree-view-source ()
"View the file containing the class' declaration and position
cursor on it."
(interactive)
(tree-goto-class t))
;;;
;;; View or find the declaration of the class point is on.
;;;
(defun tree-goto-class (view)
(let* ((class (tree-class (tree-get-tree-at-point)))
(file (class-file class))
(browse (make-browse
:name (class-name class)
:pattern (class-pattern class)
:file (class-file class)
:point (class-point class))))
(browse-find-pattern browse
(list @header class nil)
file @tags-filename view)))
;;;
;;; Return the CLASS structure for the class the cursor is on.
;;; This function reads the name of the class from the current
;;; buffer, and searches the class tree for a class with the
;;; name found.
;;;
(defun tree-get-tree-at-point ()
(let (begin name tree)
(save-excursion
(save-restriction
;; Find the name in the buffer
(widen)
(move-to-column tree-left-margin)
(skip-chars-forward " \t")
(setf begin (point))
(skip-chars-forward "^ \t\n\r")
;; Get the class description
(setf name (buffer-substring begin (point))
tree (get (intern-soft name @tree-obarray) 'browse-root))
(unless tree
(error "No information about %s found." name))
tree))))
;;;
;;; Find DESCRIPTION STRUC in file FILE. If VIEW is non-NIL,
;;; view file else find the file. FILE is not taken out of
;;; STRUC here because the filename in STRUC may be NIL in which
;;; case the filename of the class description is used.
;;;
;;; INFO is a list (HEADER CLASS-OR-MEMBER MEMBER-LIST).
;;;
(defun browse-find-pattern (struc info file tags-filename
&optional view)
(unless file
(error "Sorry, no file information available for %s." (browse-name struc)))
;; Expand the file name and check if it is valid. All file
;; names are relative to the path of the tags file name.
(setf file (expand-file-name file (file-name-directory tags-filename)))
(unless (file-readable-p file) (error "File %s isn't readable." file))
;; When viewing, set view-mode-hook, else simply find the file.
(if view
(progn (setf browse-position-to-view struc
browse-info-to-view info)
(unless (boundp 'view-hook) (setq view-hook nil))
(push 'browse-view/find view-hook)
(view-file file))
(find-file file)
(browse-view/find struc info)))
;;;
;;; Generate a suitable regular expression for a member or class
;;; name.
(defun browse-quote-name (name)
(loop with regexp = (regexp-quote name)
with start = 0
finally return regexp
while (string-match "[ \t]+" regexp start)
do (setf (substring regexp (match-beginning 0) (match-end 0))
"[ \t]*"
start (+ (match-beginning 0) 5))))
;;;
;;; Construct a regexp for a class declaration.
;;;
(defmacro browse-construct-class-regexp (name)
(` (concat "^[ \t]*\\(template[ \t\n]*<.*>\\)?"
"[ \t\n]*\\(class\\|struct\\|union\\).*\\S_"
(browse-quote-name (, name))
"\\S_")))
;;;
;;; Construct a regexp for matching a variable.
;;;
(defmacro browse-construct-variable-regexp (name)
(` (concat "\\S_" (browse-quote-name (, name)) "\\S_")))
;;;
;;; Construct a regexp for matching a function definition or declaration.
;;;
(defun browse-construct-function-regexp (name)
(concat "^[a-zA-Z0-9_:*&<>, \t]*\\S_"
(browse-quote-name name)
"[ \t\n]*("))
;;;
;;; Load a regexp from a separate regexp file.
;;;
(defun browse-pattern-from-regexp-file (file point)
(save-excursion
(set-buffer (find-file-noselect file))
(goto-char point)
(let ((s (read (current-buffer))))
(if s (concat "^.*" (regexp-quote s))))))
;;;
;;; Find a DESCRIPTION. This is a little hack: Class mode allows
;;; you to find or view a file containing a description. To be
;;; able to do a search in a viewed buffer, view-mode-hook is
;;; temporarily set to this function (STRUC is NIL then,
;;; BROWSE-POSITION-TO-VIEW holds the DESCRIPTION to search for).
;;;
;;; INFO is a list (TREE-HEADER TREE-OR-MEMBER MEMBER-LIST).
;;;
(defun* browse-view/find (&optional position info
&aux viewing)
(unless position
(pop view-hook)
(setf viewing t
position browse-position-to-view
info browse-info-to-view))
(widen)
(let* ((pattern (browse-pattern position))
(start (browse-point position))
(offset 100)
found)
(destructuring-bind (header class-or-member member-list) info
;; If no pattern is specified, do your best to contruct
;; one from the member name. If the pattern is a number,
;; it is the position of the pattern in the pattern file.
(setq pattern
(typecase pattern
(string (concat "^.*" (regexp-quote pattern)))
(number (browse-pattern-from-regexp-file
(tree-header-regexp-file header) pattern))))
(unless pattern
(typecase class-or-member
(member
(case member-list
((tree-member-variables tree-static-variables tree-types)
(setf pattern (browse-construct-variable-regexp
(browse-name position))))
(otherwise
(setf pattern (browse-construct-function-regexp
(browse-name position))))))
(class
(setf pattern (browse-construct-class-regexp
(browse-name position))))))
;; Begin searching some OFFSET from the original point where the
;; regular expression was found by the parse, and step forward.
;; When there is no regular expression in the database and a member
;; definition/declaration was not seen by the parser, START will
;; be 0.
(when (and (boundp 'browse-debug) browse-debug)
(y-or-n-p (format "start = %d" start))
(y-or-n-p pattern))
(setf found
(loop do (goto-char (max (point-min) (- start offset)))
when (re-search-forward pattern (+ start offset) t) return t
never (bobp)
do (incf offset offset)))
(cond (found
(beginning-of-line)
(run-hooks 'browse-find-hook))
((numberp (browse-pattern position))
(goto-char start)
(if browse-not-found-hook
(run-hooks 'browse-not-found-hook)
(message "Not found.")
(sit-for 2)))
(t
(if browse-not-found-hook
(run-hooks 'browse-not-found-hook)
(unless viewing
(error "Not found."))
(message "Not found.")
(sit-for 2)))))))
;;;
;;; Display marks in the tree.
;;;
(defun tree-redisplay-marks (start end)
(interactive)
(save-excursion
(browse-output
(catch 'end
(goto-char (point-min))
(dolist (root @tree)
(tree-display-tree-marks root start end))))
(tree-update-mode-line)))
(defun tree-display-tree-marks (tree start end)
(when (>= (point) start)
(delete-char 1)
(insert (if (tree-mark tree) ?> ? ))
(let ((start (1- (point)))
(end (point)))
(browse-put-text-property start end 'browser 'mark)
(browse-put-text-property start end 'mouse-face 'highlight)
(browse-set-face start end tree-mark-face)))
(forward-line 1)
(when (> (point) end) (throw 'end nil))
(dolist (sub (tree-subclasses tree))
(tree-display-tree-marks sub start end)))
;;;
;;; Redisplay the complete tree.
;;;
(defun tree-redisplay (&optional quiet)
(interactive)
(or quiet (message "Displaying..."))
(save-excursion
(browse-output
(erase-buffer)
(tree-display-tree)))
(tree-update-mode-line)
(or quiet (message "")))
;;;
;;; Display a single class and recursively it's subclasses.
;;;
(defun* tree-display-tree (&aux stack1 stack2 start)
(setq stack1 (make-list (length @tree) 0)
stack2 (copy-list @tree))
(loop while stack2
as level = (pop stack1)
as tree = (pop stack2)
as class = (tree-class tree) do
(let ((start-of-line (point))
start-of-class-name end-of-class-name)
;; Insert mark
(insert (if (tree-mark tree) ">" " "))
(browse-set-face (1- (point)) (point) tree-mark-face)
;; Indent and insert class name
(browse-move-to-column (+ (* level @indentation)
tree-left-margin))
(setq start (point))
(insert (class-name class))
(browse-set-face start (point) (if (zerop level)
tree-root-class-face
tree-normal-face))
(setf start-of-class-name start
end-of-class-name (point))
;; If filenames are to be displayed...
(when @show-filenames
(browse-move-to-column tree-source-file-column)
(setq start (point))
(insert "<" (or (class-file class) "unknown") ">")
(browse-set-face start (point) tree-filename-face))
(browse-put-text-property start-of-line (1+ start-of-line)
'mouse-face 'highlight)
(browse-put-text-property start-of-line (1+ start-of-line)
'browser 'mark)
(browse-put-text-property start-of-class-name end-of-class-name
'mouse-face 'highlight)
(browse-put-text-property start-of-class-name end-of-class-name
'browser 'class-name)
(insert "\n"))
;; Push subclasses, if any.
(when (tree-subclasses tree)
(setq stack2 (nconc (copy-list (tree-subclasses tree)) stack2)
stack1 (nconc (make-list (length (tree-subclasses tree))
(1+ level))
stack1)))))
;;;
;;; Return the buffer name of a tree which is associated with a
;;; file.
;;;
(defun tree-frozen-buffer-name (tags-file)
(concat tree-buffer-name " (" tags-file ")"))
;;;
;;; Update the tree buffer mode line.
;;;
(defun tree-update-mode-line ()
(setf @mode-strings
(concat (if @frozen (or buffer-file-name @tags-filename))
(if (buffer-modified-p) "-**")))
(browse-rename-buffer-safe (if @frozen
(tree-frozen-buffer-name @tags-filename)
tree-buffer-name))
(set-buffer-modified-p (buffer-modified-p)))
;;;
;;; Collapse/ expand tree branches.
;;;
(defun tree-expand-branch (arg)
"Expand a sub-tree that has been previously collapsed.
With prefix arg, expand all sub-trees in buffer."
(interactive "P")
(if arg
(tree-expand-all arg)
(tree-collapse nil)))
(defun tree-collapse-branch (arg)
"Fold (do no longer display) the subclasses of the class
the cursor is on. With prefix, fold all trees in the buffer."
(interactive "P")
(if arg
(tree-expand-all (not arg))
(tree-collapse t)))
(defun tree-expand-all (collapse)
"Expand or fold (with prefix arg) all trees in the buffer."
(interactive "P")
(let ((line-end (if collapse "^\n" "^\r"))
(insertion (if collapse "\r" "\n")))
(browse-output
(save-excursion
(goto-char (point-min))
(while (not (progn (skip-chars-forward line-end)
(eobp)))
(when (or (not collapse)
(looking-at "\n "))
(delete-char 1)
(insert insertion))
(when collapse
(skip-chars-forward "\n ")))))))
(defun tree-unhide-bases ()
"Unhide the line the cursor is on and all lines belonging to
base classes."
(browse-output
(save-excursion
(let (indent last-indent)
(skip-chars-backward "^\r\n")
(when (not (looking-at "[\r\n][^ \t]"))
(skip-chars-forward "\r\n \t")
(while (and (or (null last-indent) ;first time
(> indent 1)) ;not root class
(re-search-backward "[\r\n][ \t]*" nil t))
(setf indent (- (match-end 0)
(match-beginning 0)))
(when (or (null last-indent)
(< indent last-indent))
(setf last-indent indent)
(when (looking-at "\r")
(delete-char 1)
(insert 10)))
(backward-char 1)))))))
(defun tree-hide-line (collapse)
"Hide a single line in the tree."
(save-excursion
(browse-output
(skip-chars-forward "^\r\n")
(delete-char 1)
(insert (if collapse 13 10)))))
(defun tree-collapse (collapse)
"Collapse or expand a branch of the tree."
(browse-output
(save-excursion
(beginning-of-line)
(skip-chars-forward "> \t")
(let ((indentation (current-column)))
(while (and (not (eobp))
(save-excursion (skip-chars-forward "^\r\n")
(goto-char (1+ (point)))
(skip-chars-forward "> \t")
(> (current-column) indentation)))
(tree-hide-line collapse)
(skip-chars-forward "^\r\n")
(goto-char (1+ (point))))))))
;;;
;;; Read a class name from the minibuffer and position point on
;;; the class read.
;;;
(defun tree-position-on-class (&optional class)
"Read a class name from the minibuffer with completion and
position cursor on it."
(interactive)
(browse-completion-ignoring-case
(browse-save-selective
;; If no class specified, read the class name from mini-buffer
(unless class
(setf class (completing-read "Goto class: " (tree-alist) nil t)))
;; Goto buffer start and remove restrictions
(goto-char (point-min))
(widen)
(setf selective-display nil)
;;search for the class name in buffer
(setq browse-last-regexp (concat "[\r\n]?[ \t]*" class "[ \t\r\n]"))
(unless (re-search-forward browse-last-regexp nil t)
(error "Not found."))
(tree-unhide-bases)
(backward-char)
(skip-chars-backward "^ \t\n")
(when (looking-at "\n")
(forward-char 1)))))
;;;
;;; Mouse support.
;;;
;;; Depending on the location of the click event and the number of
;;; clicks do the following:
;;; Location Button Clicks Action
;;; ----------------------------------------------------------
;;; Left margin 1 1 Mark/unmark class
;;; class name 1 2 collapse/expand subtree
;;; class name 2 1 View class declaration
;;; class name 2 2 Find class declaration
;;; The text property 'browser-field gives one of the following
;;; symbols that indicate where we are
;;; 'mark
;;; 'class-name
;;; 'file-name
(defun tree-class-object-menu (event)
(let* ((menu '("Class"
("Functions" . tree-show-fns)
("Variables" . tree-show-vars)
("Static functions" . tree-show-sfns)
("Static variables" . tree-show-svars)
("Friends" . tree-show-friends)
("Types" . tree-show-types)
("--")
("View" . tree-view-source)
("Find" . tree-find-source)
("--")
("Mark" . tree-toggle-mark)
("--")
("Collapse" . tree-collapse-branch)
("Expand" . tree-expand-branch)))
(selection (x-popup-menu event (list "Class2" menu))))
(when selection
(call-interactively selection))))
(defun tree-buffer-object-menu (event)
(let* ((menu '("Buffer"
("Filenames" . tree-toggle-filenames)
("Indentation" . tree-set-indentation)
("Unmark" . tree-unmark)
("Expand all" . tree-expand-all)
("Statistics" . tree-show-statistics)
("Find class" . tree-position-on-class)
("Member buffer" . tree-pop-to-members)))
(selection (x-popup-menu event (list "Buffer" menu))))
(unless (null selection)
(call-interactively selection))))
(defun tree-mouse-2 (event)
"Show member functions member buffer for class mouse is on."
(interactive "e")
(let* ((where (posn-point (event-start event)))
(property (get-text-property where 'browser)))
(mouse-set-point event)
(case (event-click-count event)
(1
(case property
(class-name (tree-class-object-menu event))
(t (tree-buffer-object-menu event))))
(2
(case property
(class-name (tree-show-fns)))))))
(defun tree-mouse-1 (event)
"Expand/ collapse a tree branch."
(interactive "e")
(mouse-set-point event)
(case (event-click-count event)
(2
(let ((collapsed (save-excursion
(skip-chars-forward "^\r\n")
(looking-at "\r"))))
(tree-collapse (not collapsed))))))
;;;
;;; Install WRITE-FILE hook that saves a tree buffer as Lisp
;;; data structures to the file it was loaded from.
;;;
(defun* browse-write-tree-hook ()
"Write current buffer as a tree. Return T to indicate that no
further actions have to be taken by WRITE-FILE. This function has to
be the first in WRITE-FILE-HOOKS. If it is not, it will display a
message."
(unless (eq (car write-file-hooks) 'browse-write-tree-hook)
(message "Please see documentation of browse-write-tree-hook.")
(sit-for 4))
(when (tree-buffer-p (current-buffer))
(tree-save)
(return-from browse-write-tree-hook t)))
(add-hook 'write-file-hooks 'browse-write-tree-hook)
(provide 'br-tree)
;; end of `tree.el'.