cgit.sxemacs.org Git - packages/blob - xemacs-packages/eieio/tree.el

   1 ;;; tree.el --- Draw a tree with text characters an manipulate it.
   2
   3 ;;; Copyright (C) 1996, 1998, 1999, 2001, 2005 Eric M. Ludlam
   4 ;;
   5 ;; Author: <zappo@gnu.org>
   6 ;; Version: 0.3
   7 ;; RCS: $Id: tree.el,v 1.4 2007-11-26 15:01:07 michaels Exp $
   8 ;; Keywords: OO, tree
   9 ;;
  10 ;; This program is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14 ;;
  15 ;; This program is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19 ;;
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24 ;;
  25 ;; Please send bug reports, etc. to zappo@gnu.org
  26
  27 ;;; Commentary:
  28 ;;   Many new IDEs provide a tree of some structure-or-other to express the
  29 ;; structural organization of data.  This is a feature lacking in Emacs,
  30 ;; and this is some code to provide that functionality.
  31 ;;
  32 ;;  The interactive command `tree-test-it-all' will display a demo tree,
  33 ;; and `directory-tree-thing' will display a directory hierarchy from
  34 ;; the default directory of the current buffer.
  35 ;;
  36 ;; You can access general tree commands to play with this mode using
  37 ;; the functions:
  38 ;; tree-test-it-all  - bogus data that lets you see how tree-mode works
  39 ;; eieio-class-tree  - show all currently defined eieio classes and
  40 ;;                     their current inheritance organization
  41 ;; directory-tree-thing - Draw a tree corresponding to the current
  42 ;;                     directory.
  43 ;;
  44 ;; In all tree modes:
  45 ;; RET & mouse-1
  46 ;;       will select a node: usually printing something simple in the
  47 ;;       minibuffer.
  48 ;; e & mouse-2
  49 ;;       will edit a node: bring up a file/directory/editor for that
  50 ;;       object.
  51 ;; x & mouse-3
  52 ;;       expand or deflate a node and it's children.  Shrunken nodes
  53 ;;       will have elipses `...' in them to indicate that more data
  54 ;;       could be expanded.
  55 ;;
  56 ;; Creating a new tree mode:
  57 ;; 1) Look at an example
  58 ;; 2) Create a new tree-node class and add whatever slots you need
  59 ;; 3) Create a place to make a tree with `tree-new-buffer'
  60 ;; 4) Set root of tree ith `tree-set-root'
  61 ;; 5) Add nodes ass you see fit with `tree-add-child'
  62 ;; 6) Draw the tree with `tree-refresh-tree'
  63 ;; 7) Modify select, edit, and change-scope to do whatever you need.
  64 ;;
  65 ;; REQUIRES: Emacs 19.30 or better and eieio
  66
  67 ;; requires emacs 19 with arbitrary text-properties
  68
  69 (require 'eieio)
  70
  71 ;;;
  72 ;; Variable definitions
  73
  74 ;;; Code:
  75 (defvar tree-map nil "Keymap used in tree mode.")
  76 (if tree-map
  77     ()
  78   (setq tree-map (make-sparse-keymap))
  79   (define-key tree-map "\r" 'tree-select-node)
  80   (define-key tree-map "\n" 'tree-select-node)
  81   (define-key tree-map [mouse-1] 'tree-select-node-mouse)
  82   (define-key tree-map "e" 'tree-edit-node)
  83   (define-key tree-map [mouse-2] 'tree-edit-node-mouse)
  84   (define-key tree-map "x" 'tree-expand-or-contract-node)
  85   (define-key tree-map [mouse-3] 'tree-expand-or-contract-node-mouse)
  86   )
  87
  88 (defconst tree-ul-char "+")
  89 (defconst tree-ur-char "+")
  90 (defconst tree-ll-char "+")
  91 (defconst tree-lr-char "+")
  92 (defconst tree-vertical-char "|")
  93 (defconst tree-horizontal-char "-")
  94
  95 (defvar tree-root-node nil
  96   "The root node of a tree in a given tree buffer.")
  97 (make-variable-buffer-local 'tree-root-node)
  98
  99 (defvar tree-buffer-mode 'tree-center-box-1
 100   "Current mode of a tree buffer.
 101
 102 Valid values are:
 103 'tree-center-box-1 - nodes are boxed w/ 1 line of text in center of region
 104                      this is default if this value is unknown
 105 'tree-top-box-1    - nodes are boxed w/ 1 line of text @ top of region
 106 'tree-bottom-box-1 - nodes are boxed w/ 1 line of text @ bottom of region")
 107 (make-variable-buffer-local 'tree-buffer-mode)
 108
 109 (defvar tree-face 'bold
 110   "Face used inside tree-boxes.")
 111
 112 ;;;
 113 ;; Mode management
 114 ;;
 115 (defun tree-mode ()
 116   "Takes the current buffer, and initialize tree mode upon it."
 117   (kill-all-local-variables)
 118   (use-local-map tree-map)
 119   (setq major-mode 'tree-mode
 120         mode-name "TREE")
 121   (setq truncate-lines t)       ; no line-wrapping
 122   (run-hooks 'tree-mode-hook)
 123 ;  (setq mode-line-format
 124 ;       (list
 125 ;        'mode-line-modified
 126 ;        "--TREE: %15b %[(" 'mode-name 'minor-mode-alist "%n)%]--"
 127 ;        '(line-number-mode "L%l--%-")))
 128
 129 )
 130
 131 (defun tree-new-buffer (name)
 132   "Create a buffer called NAME to display some tree type things.
 133 Return the newly created buffer."
 134   (save-excursion
 135     (set-buffer (get-buffer-create name))
 136     (tree-mode)
 137     (current-buffer)))
 138
 139 (defun tree-new-frame (name)
 140   "Create a new frame NAME and set it up to use graphic characters.
 141 Returns the newly created frame"
 142   (let ((nf (make-frame (list
 143                          (cons 'name name)
 144                          '(height . 30)
 145                          '(width . 80)
 146                          ;; I'd like to use a nicer font, but...
 147                          ;; '(font . "-dec-terminal-*-*-*-*-*-*-*-*-*-*-*-*")
 148                          '(minibuffer . nil))))
 149         (nb (tree-new-buffer name))
 150         (cf (selected-frame)))
 151     ;; set the buffer we are about to play with here...
 152     (select-frame nf)
 153     (switch-to-buffer nb)
 154     (select-frame cf)
 155     nf))
 156 \f
 157 ;;;
 158 ;; display management
 159 ;;
 160 (defun tree-refresh-tree ()
 161   "Refresh the tree structure which is currently active in this buffer."
 162   (message "Refreshing tree...")
 163   ;; first-things first.  Cache the height of every node in the tree
 164   (tree-level-height tree-root-node)
 165   ;; Now fill the buffer with stuff
 166   (insert (make-string (oref tree-root-node height) ?\n))
 167   ;; Now loop over every node building the tree
 168   (tree-draw-node tree-root-node t t
 169                   (+ (tree-node-width tree-root-node) 2) 1 0)
 170   (message "Refreshing tree...Done")
 171   )
 172
 173 (defun tree-draw-node (node first last width toprow leftmargin)
 174   "Draw the single NODE and it's children at a correct estimated position.
 175 Really calls a function based upon `tree-buffer-mode'.
 176 FIRST LAST WIDTH TOPROW and LEFTMARGIN are passed along."
 177   (funcall tree-buffer-mode node first last width toprow leftmargin))
 178
 179 (defun tree-center-box-1 (node first last width toprow leftmargin)
 180   "As `tree-draw-node' except that we draw 1-line text w/ a box around it.
 181 NODE FIRST LAST WIDTH TOPROW and LEFTMARGIN are passed along."
 182   (tree-box-1 node first last width toprow leftmargin 'center))
 183
 184 (defun tree-top-box-1 (node first last width toprow leftmargin)
 185   "As `tree-draw-node' except that we draw 1-line text w/ a box around it.
 186 NODE FIRST LAST WIDTH TOPROW and LEFTMARGIN are passed along."
 187   (tree-box-1 node first last width toprow leftmargin 'top))
 188
 189 (defun tree-bottom-box-1 (node first last width toprow leftmargin)
 190   "As `tree-draw-node' except that we draw 1-line text w/ a box around it.
 191 NODE FIRST LAST WIDTH TOPROW and LEFTMARGIN are passed along."
 192   (tree-box-1 node first last width toprow leftmargin 'bottom))
 193
 194 (defun tree-box-1 (node first last width toprow leftmargin &optional pos)
 195   "Draw a single NODE and it's children at a correct estimated position.
 196 FIRST and LAST are not used.  WIDTH specifies how much space this row
 197 will take.  TOPROW specifies what row this node starts at, and
 198 LEFTMARGIN specifies how far out on the left this node can draw
 199 itself.
 200 Optional argument POS is a postion."
 201   (with-slots ((h height) (kids children) (p parent) (nm name) (ex expand))
 202       node
 203     (let ((tpos
 204             (cond ((eq pos 'center) (- (/ h 2) 1))
 205                   ((eq pos 'top) 0)
 206                   ((eq pos 'bottom) (- h 3))
 207                   (t (error "Illegal call to tree-box-1"))))
 208            (l 0))
 209       ;;(message "Refreshing tree...[%s]" nm)
 210       ;; draw the box
 211       (tree-goto-xy leftmargin (+ tpos toprow))
 212       (insert (if p " " "") tree-ul-char)
 213       (insert (make-string (- (tree-node-width node) 2)
 214                            (aref tree-horizontal-char 0)))
 215       (insert tree-ur-char)
 216       (tree-goto-xy leftmargin (+ tpos toprow 1))
 217       (insert (if p "-" "") tree-vertical-char)
 218       (let ((p1 (point)))
 219         (insert nm)
 220         (put-text-property p1 (point) 'face tree-face)
 221         (put-text-property p1 (point) 'node-object node)
 222         (put-text-property p1 (point) 'mouse-face 'highlight)
 223         )
 224       (insert (if (oref node expand) "" "..."))
 225       (insert tree-vertical-char)
 226       (if (and kids ex)
 227           (let* ((mn (tree-node-width node))
 228                  (nd (- width mn (if p 2 1)))
 229                  (l 0))
 230             (while (< l nd)
 231               (insert "-")
 232               (setq l (1+ l)))))
 233       (tree-goto-xy leftmargin (+ tpos toprow 2))
 234       (insert (if p " " "") tree-ll-char)
 235       (insert (make-string (- (tree-node-width node) 2)
 236                            (aref tree-horizontal-char 0)))
 237       (insert tree-lr-char)
 238       ;; draw all the kids
 239       (while (and kids ex)
 240         (tree-draw-node (car kids) (= l 0) (cdr kids)
 241                         (+ (tree-level-width node) 3)
 242                         (+ toprow l) (+ leftmargin width))
 243         (setq l (+ l (oref (car kids) height)))
 244         (setq kids (cdr kids)))
 245       ;; draw the connecting lines
 246       (setq kids (oref node children))
 247       (if (and kids (oref node expand))
 248           (let ((i 1) (ok nil) (h (1- h)))
 249             (while (and (< i h) kids)
 250               (tree-goto-xy (+ leftmargin width -1) (+ toprow i))
 251               (insert
 252                (cond ((looking-at " -") (setq ok t kids (cdr kids)) "+")
 253                      (ok "|")
 254                      (t " ")))
 255               (delete-char 1)
 256               (setq i (1+ i))
 257               )))
 258       (tree-goto-xy (+ leftmargin 2) (+ tpos toprow 1))
 259       (oset node currentpos (point))
 260       )))
 261
 262 (defun tree-goto-xy (x y)
 263   "Move cursor to position X Y in buffer, and add spaces and CRs if needed."
 264   (let ((indent-tabs-mode nil)
 265         (num (goto-line y)))
 266     (if (and (= 0 num) (/= 0 (current-column))) (newline 1))
 267     (if (eobp) (newline num))
 268     ;; Now, a quicky column moveto/forceto method.
 269     (or (= (move-to-column x) x) (indent-to x))))
 270
 271 \f
 272 ;;;
 273 ;; Tree data-structure management
 274 ;;
 275 (defclass tree-node ()
 276   ((name :initarg :name
 277          :initform nil)
 278    (children :initarg :children
 279              :initform nil)
 280    (expand :initarg :expand
 281            :initform t)
 282    (parent :initarg :parent
 283            :initform nil)
 284    (height :initarg :height
 285            :initform 3)
 286    (currentpos :initform 0)
 287    )
 288   "Base class for a tree node")
 289
 290 (defmethod select ((tn tree-node))
 291   "Action to take when first mouse is clicked."
 292   (message "Clicked on node %s" (object-name tn))
 293   )
 294 (defmethod edit ((tn tree-node))
 295   "Action to take when middle mouse button is clicked."
 296   (let ((nn (read-string "New name: ")))
 297     (oset tn name nn))
 298   (erase-buffer)
 299   (tree-refresh-tree)
 300   (goto-char (oref tn currentpos))
 301   )
 302 (defmethod change-scope ((tn tree-node))
 303   "Action to take when last mouse is clicked on this node"
 304   (if (oref tn children)
 305       (progn
 306         (oset tn expand (not (oref tn expand)))
 307         (erase-buffer)
 308         (tree-refresh-tree)
 309         (goto-char (oref tn currentpos))
 310         )))
 311
 312 (defun tree-set-root (node)
 313   "Create a new tree NODE with the specified name, and make it the root."
 314   (setq tree-root-node node)
 315   )
 316
 317 (defun tree-new-node (name)
 318   "Create a new tree node with specified text NAME."
 319   (tree-node name :name name))
 320
 321 (defun tree-add-child (parent child)
 322   "Add to PARENT variable `tree-node' the variable `tree-node' CHILD.
 323 Returns child to aid in building quick trees."
 324   (oset child parent parent)
 325   (oset parent children (append (oref parent children) (list child)))
 326   child)
 327
 328 (defun tree-sort-elements (node)
 329   "Sort all children of NODE, recurse."
 330   (let ((k (oref node children)))
 331     (setq k (sort k '(lambda (a b) (string< (oref a name) (oref b name)))))
 332     (oset node children k)
 333     (while k
 334       (tree-sort-elements (car k))
 335       (setq k (cdr k)))))
 336
 337 (defun tree-trim-below (node depth)
 338   "Set the expand field for NODE to nil for all nodes below DEPTH."
 339   (let ((k (oref node children)))
 340     (if (and k (<= depth 1)) (oset node expand nil))
 341     (while k
 342       (tree-trim-below (car k) (1- depth))
 343       (setq k (cdr k)))))
 344
 345 \f
 346 ;;;
 347 ;; Tree node statistics
 348 ;;
 349
 350 (defun tree-node-width (node)
 351   "Return the width of NODE."
 352   (+ (length (oref node name)) 2 (if (not (oref node expand)) 3 0)))
 353
 354 (defun tree-level-width (node)
 355   "Return the widest box to appear under NODE."
 356   (let ((kids (oref node children))
 357         (w 0))
 358     (while kids
 359       (let ((tl (tree-node-width (car kids))))
 360         (if (and (< w tl) (oref (car kids) children) (oref (car kids) expand))
 361             (setq w tl)))
 362       (setq kids (cdr kids)))
 363     w))
 364
 365 (defun tree-level-height (node)
 366   "Return the total height in chars of all nodes under NODE.
 367 Cache the height into each node for later use"
 368   (let ((kids (oref node children))
 369         (h 0))
 370     (if (or (not kids) (not (oref node expand)))
 371         (setq h 3)
 372       (while kids
 373         (setq h (+ h (tree-level-height (car kids))))
 374         (setq kids (cdr kids))))
 375     (oset node height h)
 376     h))
 377
 378 \f
 379 ;;;
 380 ;; Tree keyboard commands
 381 ;;
 382
 383 (defun tree-select-node ()
 384   "Activate the node currently under (point), or bell if none.
 385 Requires text-properties"
 386   (interactive)
 387   (let ((node (get-text-property (point) 'node-object)))
 388     (if node
 389         (select node)
 390       (error "There is no tree-node under point"))))
 391
 392 (defun tree-select-node-mouse ()
 393   "Activate the node currently under (point), or bell if none.
 394 Requires text-properties"
 395   (interactive)
 396   (call-interactively 'mouse-set-point)
 397   (let ((node (get-text-property (point) 'node-object)))
 398     (if node
 399         (select node)
 400       (error "There is no tree-node under point"))))
 401
 402 (defun tree-edit-node ()
 403   "Activate the node currently under (point), or bell if none.
 404 Requires text-properties"
 405   (interactive)
 406   (let ((node (get-text-property (point) 'node-object)))
 407     (if node
 408         (edit node)
 409       (error "There is no tree-node under point"))))
 410
 411 (defun tree-edit-node-mouse ()
 412   "Activate the node currently under (point), or bell if none.
 413 Requires text-properties"
 414   (interactive)
 415   (call-interactively 'mouse-set-point)
 416   (let ((node (get-text-property (point) 'node-object)))
 417     (if node
 418         (edit node)
 419       (error "There is no tree-node under point"))))
 420
 421 (defun tree-expand-or-contract-node ()
 422   "Activate the node currently under (point), or bell if none.
 423 Requires text-properties"
 424   (interactive)
 425   (let ((node (get-text-property (point) 'node-object)))
 426     (if node
 427         (change-scope node)
 428       (error "There is no tree-node under point"))))
 429
 430 (defun tree-expand-or-contract-node-mouse ()
 431   "Activate the node currently under (point), or bell if none.
 432 Requires text-properties"
 433   (interactive)
 434   (call-interactively 'mouse-set-point)
 435   (let ((node (get-text-property (point) 'node-object)))
 436     (if node
 437         (change-scope node)
 438       (error "There is no tree-node under point"))))
 439
 440 \f
 441 ;;;
 442 ;; Tree test case
 443 ;;
 444
 445 ;;;###autoload
 446 (defun tree-test-it-all ()
 447   "Try using various features of tree mode in a demo of it's display."
 448   (interactive)
 449   ;; create a new buffer
 450   (switch-to-buffer (tree-new-buffer "*TREE DEMO*"))
 451   (erase-buffer)
 452   ;; set up the root node and some children
 453   (let* ((ntn (tree-set-root (tree-new-node "root")))
 454          (stn1 (tree-add-child ntn (tree-new-node "Bob")))
 455          (stn2 (tree-add-child ntn (tree-new-node "Stan")))
 456          (stn3 (tree-add-child ntn (tree-new-node "Valarie")))
 457          (sstn1 (tree-add-child stn1 (tree-new-node "Bob1")))
 458          (sstn2 (tree-add-child stn1 (tree-new-node "Bob2")))
 459          (sstn3 (tree-add-child stn1 (tree-new-node "Bob3")))
 460          (sstn4 (tree-add-child stn1 (tree-new-node "Bob4")))
 461          (sstn5 (tree-add-child stn3 (tree-new-node "Valarie2")))
 462          (sstn6 (tree-add-child stn3 (tree-new-node "Valarie3")))
 463          (ssstn1 (tree-add-child sstn4 (tree-new-node "Bobby1")))
 464          (ssstn2 (tree-add-child sstn4 (tree-new-node "Bobby2")))
 465          ;(ssstn2 (tree-add-child sstn4 (tree-new-node "Bobby3")))
 466          ))
 467   (tree-refresh-tree)
 468   )
 469
 470 \f
 471 ;;;
 472 ;; Tree demo using eieio class structures
 473 ;;
 474 (defclass eieio-tree-node (tree-node)
 475   ((class :initarg :class
 476           :initform nil))
 477   "Tree node used to represent eieio classes")
 478
 479 (defmethod edit ((etn eieio-tree-node))
 480   "Don't really edit, but pull up details about the given widget using
 481 `eieio-describe-class'"
 482   (eieio-describe-class (oref etn class)))
 483
 484 (defmethod select ((etn eieio-tree-node))
 485   "Display a tiny bit of info about this object which might be useful"
 486   (message "%s" (class-name (oref etn class)))
 487   )
 488
 489 (defun eieio-new-node (class)
 490   "Create a new widget tree node with the specified WIDGET slot.
 491 Argument CLASS is the class we are displaying."
 492   (eieio-tree-node (symbol-name class)
 493                    :name (symbol-name class)
 494                    :class class)
 495   )
 496
 497 ;;;###autoload
 498 (defun eieio-class-tree (&optional root-class)
 499   "Displays a class tree using the TREE package in another buffer.
 500 Optional argument ROOT-CLASS is the starting point."
 501   (interactive)
 502   (if (not root-class) (setq root-class 'eieio-default-superclass))
 503   (switch-to-buffer (tree-new-buffer "*EIEIO CLASS TREE*"))
 504   (erase-buffer)
 505   (let ((np (tree-set-root (eieio-new-node root-class))))
 506     (eieio-tree-grow np))
 507   (tree-refresh-tree))
 508
 509 (defun eieio-tree-grow (node)
 510   "Add to NODE all children."
 511   (let* ((wk (aref (class-v (oref node class)) class-children))
 512          nn)
 513     (while wk
 514       (setq nn (eieio-new-node (car wk)))
 515       (tree-add-child node nn)
 516       (eieio-tree-grow nn)
 517       (setq wk (cdr wk))))
 518   )
 519
 520 \f
 521 ;;;
 522 ;; Tree demos using directories
 523 ;;
 524 (defclass dirtree-node (tree-node)
 525   ((pathname :initarg :path
 526              :initform nil)
 527    (haschildren :initarg :haschildren
 528                 :initform unknown)
 529    )
 530   "A tree-node child class for displaying a directory.")
 531
 532 (defmethod edit ((dtn dirtree-node))
 533   "Action to take when this node is clicked."
 534   (find-file (format "%s%s" (oref dtn pathname) (oref dtn name)))
 535 )
 536 (defmethod select ((dtn dirtree-node))
 537   "Action to take when this node is clicked."
 538   (shell-command (format "ls -ld %s%s" (oref dtn pathname)
 539                          (oref dtn name)))
 540 )
 541 (defmethod change-scope ((dtn dirtree-node))
 542   "Action to take when last mouse is clicked on this node"
 543   ;; check for new nodes...
 544   (if (equal (oref dtn haschildren) 'unknown)
 545       (let ((path-path (oref dtn pathname)))
 546         (directory-tree-more-nodes dtn 1)))
 547   (if (oref dtn children)
 548       (progn
 549         (oset dtn expand (not (oref dtn expand)))
 550         (erase-buffer)
 551         (tree-refresh-tree)
 552         (goto-char (oref dtn currentpos))
 553         )
 554     ))
 555
 556 (defun dirtree-new (name path)
 557   "Create a new directory tree node.
 558 Argument NAME is the name of the tree node.
 559 Argument PATH is the path to that file."
 560   (dirtree-node name :name name :path path))
 561
 562 ;;;###autoload
 563 (defun directory-tree-thing (ppath)
 564   "Start at the current directory, and build a giant tree of files.
 565 Argument PPATH is the path to the directory we are going to analyze."
 566   (interactive "fDirectory to graph: ")
 567   (let ((toppath (if (string-match "/$" ppath)
 568                      (substring ppath 0 (1- (length ppath)))
 569                    ppath)))
 570     (switch-to-buffer
 571      (tree-new-buffer (format "TREE: %s" (file-name-nondirectory toppath))))
 572     (erase-buffer)
 573     (let ((node (tree-set-root (dirtree-new
 574                                 (file-name-nondirectory toppath)
 575                                 (file-name-directory toppath)
 576                                 )))
 577           (path-path (file-name-directory toppath)))
 578       (directory-tree-more-nodes node 2))
 579     (setq tree-buffer-mode 'tree-top-box-1)
 580     (message "Refreshing tree...")
 581     (tree-refresh-tree)
 582     ))
 583
 584 (defun directory-tree-more-nodes (node dokids)
 585   "Find more parts of this directory.  Do not expand kids if dokids = 0.
 586 Argument NODE is the node to display.  DOKIDS is a flag to display children."
 587   (message "Tracing directory... [%s]" (oref node name))
 588   ;; mark that we checked this guy
 589   (oset node haschildren 'known)
 590   (let* ((nm (oref node name))
 591          ;;                            path-path is letted in previous call
 592          (files (directory-files (concat path-path nm) nil nil t)))
 593     (while files
 594       (if (or (string= "." (car files))
 595               (string= ".." (car files)))
 596           ()
 597         (if (file-accessible-directory-p (concat path-path nm "/"
 598                                                  (car files)))
 599             (let ((path-path (concat path-path nm "/"))
 600                   (newnode (tree-add-child node (dirtree-new
 601                                                  (car files)
 602                                                  (concat path-path nm "/")
 603                                                  ))))
 604               ;; These directories never have subdirectories, but
 605               ;; often contain many many files!
 606               (if (and (not (member (car files)
 607                                     '(".xvpics" "SCCS" "RCS" "CVS")))
 608                        (< 0 dokids))
 609                   (progn
 610                     (directory-tree-more-nodes newnode (1- dokids))
 611                     (oset newnode children
 612                           (sort (oref newnode children)
 613                                 '(lambda (a b)
 614                                    (string< (oref a name) (oref b name)))
 615                                 ))
 616                     )))))
 617       (setq files (cdr files)))
 618     ;; mark not to expand..
 619     (if (and (= dokids 0) (oref node children))
 620         (oset node expand nil))
 621     )
 622   )
 623
 624 (provide 'tree)
 625
 626 ;;; tree.el ends here