3 ## Hierarchical Display Widget
5 ## Layout routines taken from oooold code, author unkown.
6 ## Copyright 1995-1997 Jeffrey Hobbs
8 ## jhobbs@cs.uoregon.edu, http://www.cs.uoregon.edu/~jhobbs/
10 ## source standard_disclaimer.tcl
11 ## source beer_ware.tcl
13 ## Last Update: 28 June 1997
15 ##-----------------------------------------------------------------------
17 ## hierarchy, hierarchy_dir, hierarchy_widget
19 ## ARGUMENTS && DESCRIPTION
21 ## hierarchy <window pathname> <options>
22 ## Implements a hierarchical listbox
23 ## hierarchy_dir <window pathname> <options>
24 ## Implements a hierarchical listbox using a directory view structure
25 ## for the default methods
26 ## hierarchy_widget <window pathname> <options>
27 ## Implements a hierarchical listbox using a widget view structure
28 ## for the default methods
31 ## (Any canvas option may be used with a hierarchy)
33 ## -autoscrollbar TCL_BOOLEAN DEFAULT: 1
34 ## Determines whether scrollbars automagically pop-up or
35 ## are permanently there.
37 ## -browsecmd procedure DEFAULT: noop
38 ## A command which the widget will execute when the node is expanded
39 ## to retrieve the children of a node. The widget and node path are
40 ## appended to the command as a list of node names which
41 ## form a path to the node from the root. Thus the first
42 ## element of this list will always be the root node.
44 ## -command procedure DEFAULT: noop
45 ## A command which the widget will execute when the node is toggled.
46 ## The name of the widget, the node path, and whether the children of
47 ## the node are showing (0/1) is appended to the procedure args.
49 ## -common TCL_BOOLEAN DEFAULT: 0
50 ## If this is true, when a node gets added to the selection,
51 ## all other nodes with the same *name* (regardless of
52 ## the path to the node) get selected as well. The selection
53 ## is reported only as a set of node names, not a set of node
54 ## paths. Thus selection acts like an equivalence over nodes
55 ## of the same name. Useful only in hierarchies where some
56 ## nodes in the hierarchy really refer to the same logical object.
57 ## NOTE: FEATURE NOT YET IMPLEMENTED
59 ## -decoration TCL_BOOLEAN DEFAULT: 1
60 ## If this is true, the "tree" lines are drawn.
62 ## -expand # DEFAULT: 1
63 ## an integer value for an initial depth to expand to.
65 ## -font fontname DEFAULT: fixed
66 ## The default font used for the text.
68 ## -foreground color DEFAULT: black
69 ## The default foreground color used for text of unselected nodes.
72 ## The internal space added between the image and the text for a
75 ## -nodelook procedure DEFAULT: noop
76 ## A command the widget will execute to get the look of a node.
77 ## The node is appended to the command as a list of
78 ## node-names which form a path to the node from the root.
79 ## Thus the first element of this list will always be the
80 ## root node. Also appended is a
81 ## boolean value which indicates whether the node's children
82 ## are currently displayed. This allows the node's
83 ## look to change if it is "opened" or "closed".
85 ## This command must return a 4-tuple list containing:
86 ## 0. the text to display at the node
87 ## 1. the font to use for the text
88 ## 2. an image to display
89 ## 3. the foreground color to use for the node
90 ## If no font (ie. {}) is specified then
91 ## the value from -font is used. If no image is specified
92 ## then no image is displayed.
93 ## The default is a command to which produces a nice look
94 ## for a file manager.
96 ## -paddepth # DEFAULT: 12
97 ## The indent space added for child branches.
99 ## -padstack # DEFAULT: 2
100 ## The space added between two rows
102 ## -root rootname DEFAULT: {}
103 ## The name of the root node of the tree. Each node
104 ## name must be unique amongst the children of each node.
106 ## -selectbackground color DEFAULT: red
107 ## The default background color used for the text of selected nodes.
109 ## -selectmode (single|browse|multiple) DEFAULT: browse
110 ## Like listbox modes, "multiple" is a mix of multiple && extended.
112 ## -showall TCL_BOOLEAN DEFAULT: 0
113 ## For directory nodelook, also show Unix '.' (hidden) files/dirs.
115 ## -showfiles TCL_BOOLEAN DEFAULT: 0
116 ## Show files as well as directories.
118 ## -showparent string DEFAULT: {}
119 ## For hierarchy_dir nodelook, if string != {}, then it will show that
120 ## string which will reset the root node to its parent.
122 ## RETURNS: The window pathname
125 ## These are the methods that the hierachical listbox object recognizes.
126 ## (ie - hierachy .h ; .h <method> <args>)
127 ## Any unique substring is acceptable
129 ## configure ?option? ?value option value ...?
131 ## Standard tk widget routines.
134 ## Closes the specified index (will trigger -command).
137 ## Returns the indices of the selected items. This differs from the
138 ## listbox method because indices here have no implied order.
140 ## get index ?index ...?
141 ## Returns the node paths of the items referenced. Ranges are not
142 ## allowed. Index specification is like that allowed by the index
145 ## qget index ?index ...?
146 ## As above, but the indices must be that of the item (as returned
147 ## by the index or curselection method).
150 ## Returns the hierarchy numerical index of the item (the numerical
151 ## index has no implied order relative to the list items). index
152 ## may be of the form:
154 ## number - Specifies the element as a numerical index.
155 ## root - specifies the root item.
156 ## string - Specifis an item that has that text in it's node.
157 ## @x,y - Indicates the element that covers the point in
158 ## the listbox window specified by x and y (in pixel
159 ## coordinates). If no element covers that point,
160 ## then the closest element to that point is used.
163 ## Opens the specified index (will trigger -command).
166 ## Ensures that the item specified by the index is viewable.
168 ## selection option arg
169 ## This works like the listbox selection method with the following
172 ## The selection clear option can take multiple indices, but not a range.
173 ## No arguments to clear means clear all the selected elements.
175 ## The selection set option can take multiple indices, but not a range.
176 ## The key word 'all' sets the selection for all elements.
179 ## Returns the number of items in the hierarchical listbox.
182 ## Toggles (open or closed) the item specified by index
183 ## (triggers -command).
186 ## Most Button-1 bindings on the hierarchy work in the same manner
187 ## as those for the listbox widget, as defined by the selectmode.
188 ## Those that vary are listed below:
191 ## Toggles a node in the hierarchy
194 ## The megawidget creates a global array with the classname, and a
195 ## global array which is the name of each megawidget created. The latter
196 ## array is deleted when the megawidget is destroyed.
197 ## The procedure hierarchy and those beginning with Hierarchy are
198 ## used. Also, when a widget is created, commands named .$widgetname
199 ## and Hierarchy$widgetname are created.
201 ## Cryptic source code arguments explained:
206 ##-----------------------------------------------------------------------
208 package require Widget 1.0
209 package provide Hierarchy 1.11
211 ## Create the Hiearchy megawidget class definition
213 ## In general, we cannot use $data(basecmd) in the construction, but the
214 ## scrollbar commands won't be called until after it really exists as a
216 array set Hierarchy {
218 base {canvas canvas canvas {-relief sunken -bd 1 \
219 -highlightthickness 1 \
220 -yscrollcommand [list $data(yscrollbar) set] \
221 -xscrollcommand [list $data(xscrollbar) set]}}
223 {scrollbar xscrollbar sx {-orient h -bd 1 -highlightthickness 1\
224 -command [list $data(basecmd) xview]}}
225 {scrollbar yscrollbar sy {-orient v -bd 1 -highlightthickness 1\
226 -command [list $data(basecmd) yview]}}
229 -autoscrollbar {autoScrollbar AutoScrollbar 1}
230 -browsecmd {browseCmd BrowseCmd {}}
231 -command {command Command {}}
232 -decoration {decoration Decoration 1}
233 -expand {expand Expand 1}
234 -font {font Font fixed}
235 -foreground {foreground Foreground black}
237 -nodelook {nodeLook NodeLook {}}
238 -paddepth {padDepth PadDepth 12}
239 -padstack {padStack PadStack 2}
241 -selectmode {selectMode SelectMode browse}
242 -selectbackground {selectBackground SelectBackground red}
243 -state {state State normal}
245 -showall {showAll ShowAll 0}
246 -showparent {showParent ShowParent {}}
247 -showfiles {showFiles ShowFiles 0}
249 # Create this to make sure there are registered in auto_mkindex
250 # these must come before the [widget create ...]
251 proc Hierarchy args {}
252 proc hierarchy args {}
253 widget create Hierarchy
255 proc hierarchy_dir {w args} {
256 uplevel hierarchy $w -root [list [pwd]] \
257 -nodelook Hierarchy:FileLook \
258 -command Hierarchy:FileActivate \
259 -browsecmd Hierarchy:FileList \
263 proc hierarchy_widget {w args} {
264 uplevel hierarchy $w -root . \
265 -nodelook Hierarchy:WidgetLook \
266 -command Hierarchy:WidgetActivate \
267 -browsecmd Hierarchy:WidgetList \
271 ;proc Hierarchy:construct { w } {
275 array set data [list \
277 halfpstk [expr $data(-padstack)/2] \
281 grid $data(canvas) $data(yscrollbar) -sticky news
282 grid $data(xscrollbar) -sticky ew
283 grid columnconfig $w 0 -weight 1
284 grid rowconfig $w 0 -weight 1
285 bind $data(canvas) <Configure> [list Hierarchy:Resize $w %w %h]
288 ;proc Hierarchy:init { w } {
291 set data(:$data(-root),showkids) 0
292 Hierarchy:ExpandNodeN $w $data(-root) $data(-expand)
293 if {[catch {$w see $data(-root)}]} {
294 $data(basecmd) configure -scrollregion "0 0 1 1"
298 ;proc Hierarchy:configure {w args} {
301 set truth {^(1|yes|true|on)$}
303 foreach {key val} $args {
306 set val [regexp -nocase $truth $val]
310 grid $data(xscrollbar)
311 grid $data(yscrollbar)
314 -decoration { set val [regexp -nocase $truth $val] }
315 -padstack { set data(halfpstk) [expr $val/2] }
317 ## We set this special bool val because it saves some
318 ## computation in ExpandNode, a deeply nested proc
319 set data(hasnodelook) [string compare $val {}]
322 if {[info exists data(:$data(-root),showkids)]} {
323 ## All data about items and selection should be
324 ## cleared and the items deleted
325 foreach name [concat [array names data :*] \
326 [array names data S,*]] {unset data($name)}
327 $data(basecmd) delete all
329 set data(:$val,showkids) 0
330 Hierarchy:ExpandNodeN $w $val $data(-expand)
331 ## We can reset resize because ExpandNodeN forces it
337 foreach i [array names data S,*] {
338 $data(basecmd) itemconfigure [string range $i 2 end] \
343 if {![regexp {^(normal|disabled)$} $val junk val]} {
344 return -code error "bad state value \"$val\":\
345 must be normal or disabled"
350 set val [regexp -nocase $truth $val]
351 if {$val == $data($key)} continue
352 if {[info exists data(:$data(-root),showkids)]} {
353 foreach i [array names data :*,kids] { unset data($i) }
354 foreach i [array names data :*,showkids] {
355 ## FIX - this doesn't really work dynamically
357 ## probably requires a call to Hierarchy:Redraw
366 Hierarchy:Resize $w [winfo width $data(canvas)] \
367 [winfo height $data(canvas)]
371 ;proc Hierarchy_index { w idx } {
374 if {[string match all $idx]} {
375 return [$c find withtag box]
376 } elseif {[regexp {^(root|anchor)$} $idx]} {
377 return [$c find withtag box:$data(-root)]
379 foreach i [$c find withtag $idx] {
380 if {[string match rec* [$c type $i]]} { return $i }
382 if {[regexp {@(-?[0-9]+),(-?[0-9]+)} $idx z x y]} {
383 return [$c find closest [$w canvasx $x] [$w canvasy $y] 1 text]
385 foreach i [$c find withtag box:[lindex $idx 0]] { return $i }
386 return -code error "bad hierarchy index \"$idx\":\
387 must be current, @x,y, a number, or a node name"
390 ;proc Hierarchy_selection { w args } {
391 if {[string match {} $args]} {
393 "wrong \# args: should be \"$w selection option args\""
396 set err [catch {Hierarchy_index $w [lindex $args 1]} idx]
397 switch -glob -- [lindex $args 0] {
400 ## stubbed out - too complicated to support
406 foreach arg [array names data S,*] { unset data($arg) }
407 $c itemconfig box -fill {}
409 catch {unset data(S,$idx)}
410 $c itemconfig $idx -fill {}
411 foreach idx [lrange $args 2 end] {
412 if {[catch {Hierarchy_index $w $idx} idx]} {
413 catch {unset data(S,$idx)}
414 $c itemconfig $idx -fill {}
422 if {[llength $args]==2} {
423 return -code error $idx
425 return -code error "wrong \# args:\
426 should be \"$w selection includes index\""
429 return [info exists data(S,$idx)]
434 if {[string compare {} $args]} return
435 return -code error "wrong \# args:\
436 should be \"$w selection set index ?index ...?\""
438 set c $data(basecmd); set col $data(-selectbackground)
439 if {[string match all [lindex $args 1]]} {
440 foreach i $idx { set data(S,$i) 1 }
441 $c itemconfig box -fill $col
444 $c itemconfig $idx -fill $col
445 foreach idx [lrange $args 2 end] {
446 if {![catch {Hierarchy_index $w $idx} idx]} {
448 $c itemconfig $idx -fill $col
455 return -code error "bad selection option \"[lindex $args 0]\":\
456 must be clear, includes, set"
461 ;proc Hierarchy_curselection {w} {
465 foreach i [array names data S,*] { lappend res [string range $i 2 end] }
469 ;proc Hierarchy_get {w args} {
474 if {![catch {Hierarchy_index $w $arg} idx] && \
475 [string compare {} $idx]} {
476 set tags [$data(basecmd) gettags $idx]
477 if {[set i [lsearch -glob $tags box:*]]>-1} {
478 lappend nps [string range [lindex $tags $i] 4 end]
485 ;proc Hierarchy_qget {w args} {
488 ## Quick get. Avoids expensive Hierarchy_index call
491 set tags [$data(basecmd) itemcget $arg -tags]
492 if {[set i [lsearch -glob $tags box:*]]>-1} {
493 lappend nps [string range [lindex $tags $i] 4 end]
499 ;proc Hierarchy_see {w args} {
502 if {[catch {Hierarchy_index $w $args} idx]} {
503 return -code error $idx
504 } elseif {[string compare {} $idx]} {
506 foreach {x y x1 y1} [$c bbox $idx] {top btm} [$c yview] {
507 set stk [lindex [$c cget -scrollregion] 3]
508 set pos [expr (($y1+$y)/2.0)/$stk - ($btm-$top)/2.0]
514 ;proc Hierarchy_size {w} {
516 return [llength [$data(basecmd) find withtag box]]
519 ## This will be the one called by <Double-Button-1> on the canvas,
520 ## if -state is normal, so we have to make sure that $w is correct.
522 ;proc Hierarchy_toggle { w index } {
523 Hierarchy:toggle $w $index toggle
526 ;proc Hierarchy_close { w index } {
527 Hierarchy:toggle $w $index close
530 ;proc Hierarchy_open { w index } {
531 Hierarchy:toggle $w $index open
534 ;proc Hierarchy:toggle { w index which } {
535 if {[string compare Hierarchy [winfo class $w]]} {
536 set w [winfo parent $w]
540 if {[string match {} [set np [$w get $index]]]} return
541 set np [lindex $np 0]
543 set old [$data(basecmd) cget -cursor]
544 $data(basecmd) config -cursor watch
547 close { Hierarchy:CollapseNodeAll $w $np }
548 open { Hierarchy:ExpandNodeN $w $np 1 }
550 if {$data(:$np,showkids)} {
551 Hierarchy:CollapseNodeAll $w $np
553 Hierarchy:ExpandNodeN $w $np 1
557 if {[string compare {} $data(-command)]} {
558 uplevel \#0 $data(-command) [list $w $np $data(:$np,showkids)]
560 $data(basecmd) config -cursor $old
564 ;proc Hierarchy:Resize { w wid hgt } {
567 if {[string compare {} [set box [$c bbox image text]]]} {
568 set X [lindex $box 2]
569 if {$data(-autoscrollbar)} {
570 set Y [lindex $box 3]
573 grid remove $data(xscrollbar)
575 grid $data(xscrollbar)
579 grid remove $data(yscrollbar)
581 grid $data(yscrollbar)
583 $c config -scrollregion "0 0 $X $Y"
585 ## This makes full width highlight boxes
586 ## data(width) is the default width of boxes
587 if {$X>$data(width)} {
589 foreach b [$c find withtag box] {
590 foreach {x y x1 y1} [$c coords $b] { $c coords $b 0 $y $X $y1 }
593 } elseif {$data(-autoscrollbar)} {
594 grid remove $data(xscrollbar) $data(yscrollbar)
598 ;proc Hierarchy:CollapseNodeAll { w np } {
599 if {[Hierarchy:CollapseNode $w $np]} {
601 Hierarchy:Redraw $w $np
602 Hierarchy:DiscardChildren $w $np
603 Hierarchy:Resize $w [winfo width $data(canvas)] \
604 [winfo height $data(canvas)]
608 ;proc Hierarchy:ExpandNodeN { w np n } {
610 if {[Hierarchy:ExpandNodeN_aux $w $np $n] || \
611 ([string compare $data(-root) {}] && \
612 ![string compare $data(-root) $np])} {
613 Hierarchy:Redraw $w $np
614 Hierarchy:Resize $w [winfo width $data(canvas)] \
615 [winfo height $data(canvas)]
619 ;proc Hierarchy:ExpandNodeN_aux { w np n } {
620 if {![Hierarchy:ExpandNode $w $np]} { return 0 }
621 if {$n==1} { return 1 }
624 foreach k $data(:$np,kids) {
625 Hierarchy:ExpandNodeN_aux $w "$np [list $k]" $n
630 ########################################################################
632 ## Private routines to collapse and expand a single node w/o redrawing
633 ## Most routines return 0/1 to indicate if any change has occurred
635 ########################################################################
637 ;proc Hierarchy:ExpandNode { w np } {
640 if {$data(:$np,showkids)} { return 0 }
641 set data(:$np,showkids) 1
642 if {![info exists data(:$np,kids)]} {
643 if {[string compare $data(-browsecmd) {}]} {
644 set data(:$np,kids) [uplevel \#0 $data(-browsecmd) [list $w $np]]
646 set data(:$np,kids) {}
649 if $data(hasnodelook) {
650 set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 1]]
652 set data(:$np,look) {}
654 if {[string match {} $data(:$np,kids)]} {
655 foreach {txt font img fg} $data(:$np,look) {
656 lappend tags box:$np box $np
658 if {[string compare $img {}]} {
659 ## Catch just in case the image doesn't exist
661 $c itemconfigure img:$np -image $img
665 if {[string compare $txt {}]} {
666 if {[string match {} $font]} { set font $data(-font) }
667 if {[string match {} $fg]} { set fg $data(-foreground) }
668 $c itemconfigure txt:$np -fill $fg -text $txt -font $font
669 if {[string compare $np $txt]} { lappend tags $txt }
671 $c itemconfigure box:$np -tags $tags
672 ## We only want to go through once
677 foreach k $data(:$np,kids) {
678 set knp "$np [list $k]"
679 set data(:$knp,showkids) 0
680 if $data(hasnodelook) {
681 set data(:$knp,look) [uplevel \#0 $data(-nodelook) [list $w $knp 0]]
683 set data(:$knp,look) {}
689 ;proc Hierarchy:CollapseNode { w np } {
691 if {!$data(:$np,showkids)} { return 0 }
692 set data(:$np,showkids) 0
693 if {[string match {} $data(:$np,kids)]} { return 0 }
694 if {[string compare $data(-nodelook) {}]} {
695 set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 0]]
697 set data(:$np,look) {}
699 foreach k $data(:$np,kids) { Hierarchy:CollapseNode $w "$np [list $k]" }
703 ;proc Hierarchy:DiscardChildren { w np } {
705 if {[info exists data(:$np,kids)]} {
706 foreach k $data(:$np,kids) {
707 set knp "$np [list $k]"
708 $data(basecmd) delete img:$knp txt:$knp box:$knp
709 foreach i {showkids look stkusg stack iwidth offset} {
710 catch {unset data(:$knp,$i)}
712 Hierarchy:DiscardChildren $w $knp
714 unset data(:$np,kids)
719 ## 2 parts: recompute offsets of all children from changed node path
720 ## then redraw children based on their offsets and look
722 ;proc Hierarchy:Redraw { w cnp } {
726 # When a node changes, the positions of a whole lot of things
727 # change. The size of the scroll region also changes.
730 # Calculate the new offset locations of everything
731 Hierarchy:Recompute $w $data(-root) [lrange $cnp 1 end]
733 # Next recursively move all the bits around to their correct positions.
734 # We choose an initial point (4,4) to begin at.
735 Hierarchy:Redraw_aux $w $data(-root) 4 4
737 # Necessary to make sure find closest gets the right item
738 # ordering: image > text > box
739 after idle "catch { $c raise image text; $c lower box text }"
742 ## RECOMPUTE recurses through the tree working out the relative offsets
743 ## of children from their parents in terms of stack values.
745 ## "cnp" is either empty or a node name which indicates where the only
746 ## changes have occured in the hierarchy since the last call to Recompute.
747 ## This is used because when a node is toggled on/off deep in the
748 ## hierarchy then not all the positions of items need to be recomputed.
749 ## The only ones that do are everything below the changed node (of
750 ## course), and also everything which might depend on the stack usage of
751 ## that node (i.e. everything above it). Specifically the usages of the
752 ## changed node's siblings do *not* need to be recomputed.
754 ;proc Hierarchy:Recompute { w np cnp } {
756 # If the cnp now has only one element then
757 # it must be one of the children of the current node.
758 # We do not need to Recompute the usages of its siblings if it is.
759 set cnode_is_child [expr [llength $cnp]==1]
760 if {$cnode_is_child} {
761 set cnode [lindex $cnp 0]
763 set xcnp [lrange $cnp 1 end]
766 # Run through the children, recursively calculating their usage of
767 # stack real-estate, and allocating an intial placement for each child
769 # Values do not need to be recomputed for siblings of the changed
770 # node and their descendants. For the cnode itself, in the
771 # recursive call we set the value of cnode to {} to prevent
772 # any further cnode checks.
775 if {$data(:$np,showkids)} {
776 foreach k $data(:$np,kids) {
777 set knp "$np [list $k]"
778 set data(:$knp,offset) $children_stack
779 if {$cnode_is_child && [string match $cnode $k]} {
780 set data(:$knp,stkusg) [Hierarchy:Recompute $w $knp {}]
781 } elseif {!$cnode_is_child} {
782 set data(:$knp,stkusg) [Hierarchy:Recompute $w $knp $xcnp]
784 incr children_stack $data(:$knp,stkusg)
785 incr children_stack $data(-padstack)
789 ## Make the image/text if they don't exist.
790 ## Positioning occurs in Hierarchy:Redraw_aux.
791 ## And calculate the stack usage of our little piece of the world.
792 set img_height 0; set img_width 0; set txt_width 0; set txt_height 0
794 foreach {txt font img fg} $data(:$np,look) {
795 lappend tags box:$np box $np
797 if {[string compare $img {}]} {
798 if {[string match {} [$c find withtag img:$np]]} {
799 $c create image 0 0 -anchor nw -tags [list img:$np image]
801 ## Catch just in case the image doesn't exist
803 $c itemconfigure img:$np -image $img
805 foreach {x y img_width img_height} [$c bbox img:$np] {
806 incr img_width -$x; incr img_height -$y
810 if {[string compare $txt {}]} {
811 if {[string match {} [$c find withtag txt:$np]]} {
812 $c create text 0 0 -anchor nw -tags [list txt:$np text]
814 if {[string match {} $font]} { set font $data(-font) }
815 if {[string match {} $fg]} { set fg $data(-foreground) }
816 $c itemconfigure txt:$np -fill $fg -text $txt -font $font
817 if {[string compare $np $txt]} { lappend tags $txt }
818 foreach {x y txt_width txt_height} [$c bbox txt:$np] {
819 incr txt_width -$x; incr txt_height -$y
822 if {[string match {} [$c find withtag box:$np]]} {
823 $c create rect 0 0 1 1 -tags [list box:$np box] -outline {}
825 $c itemconfigure box:$np -tags $tags
826 ## We only want to go through this once
830 if {$txt_height>$img_height} {
831 set stack $txt_height
833 set stack $img_height
836 # Now reposition the children downward by "stack"
837 set overall_stack [expr $children_stack+$stack]
839 if {$data(:$np,showkids)} {
840 set off [expr $stack+$data(-padstack)]
841 foreach k $data(:$np,kids) {
842 set knp "$np [list $k]"
843 incr data(:$knp,offset) $off
846 # remember some facts for locating the image and drawing decor
847 array set data [list :$np,stack $stack :$np,iwidth $img_width]
849 return $overall_stack
852 ;proc Hierarchy:Redraw_aux { w np deppos stkpos} {
856 $c coords img:$np $deppos $stkpos
857 $c coords txt:$np [expr {$deppos+$data(:$np,iwidth)+$data(-ipad)}] $stkpos
858 $c coords box:$np 0 [expr $stkpos-$data(halfpstk)] \
859 $data(width) [expr $stkpos+$data(:$np,stack)+$data(halfpstk)]
861 if {!$data(:$np,showkids) || [string match {} $data(:$np,kids)]} return
863 set minkid_stkpos 100000
865 set bar_deppos [expr $deppos+$data(-paddepth)/2]
866 set kid_deppos [expr $deppos+$data(-paddepth)]
868 foreach k $data(:$np,kids) {
869 set knp "$np [list $k]"
870 set kid_stkpos [expr $stkpos+$data(:$knp,offset)]
871 Hierarchy:Redraw_aux $w $knp $kid_deppos $kid_stkpos
873 if {$data(-decoration)} {
874 if {$kid_stkpos<$minkid_stkpos} {set minkid_stkpos $kid_stkpos}
875 set kid_stkpos [expr $kid_stkpos+$data(:$knp,stack)/2]
876 if {$kid_stkpos>$maxkid_stkpos} {set maxkid_stkpos $kid_stkpos}
878 $c create line $bar_deppos $kid_stkpos $kid_deppos $kid_stkpos \
882 if {$data(-decoration)} {
883 $c create line $bar_deppos $minkid_stkpos $bar_deppos $maxkid_stkpos \
890 ## DEFAULT BINDINGS FOR HIERARCHY
892 ## Since we give no border to the frame, all Hierarchy bindings
893 ## will always register on the canvas widget
895 bind Hierarchy <Double-Button-1> {
896 set w [winfo parent %W]
897 if {[string match normal [$w cget -state]]} {
901 bind Hierarchy <ButtonPress-1> {
902 if {[winfo exists %W]} { Hierarchy:BeginSelect [winfo parent %W] @%x,%y }
904 bind Hierarchy <B1-Motion> {
907 Hierarchy:Motion [winfo parent %W] @%x,%y
909 bind Hierarchy <ButtonRelease-1> { tkCancelRepeat }
910 bind Hierarchy <Shift-1> { Hierarchy:BeginExtend [winfo parent %W] @%x,%y }
911 bind Hierarchy <Control-1> { Hierarchy:BeginToggle [winfo parent %W] @%x,%y }
912 bind Hierarchy <B1-Leave> {
915 Hierarchy:AutoScan [winfo parent %W]
917 bind Hierarchy <B1-Enter> { tkCancelRepeat }
919 ## Should reserve L/R U/D for traversing nodes
920 bind Hierarchy <Up> { %W yview scroll -1 units }
921 bind Hierarchy <Down> { %W yview scroll 1 units }
922 bind Hierarchy <Left> { %W xview scroll -1 units }
923 bind Hierarchy <Right> { %W xview scroll 1 units }
925 bind Hierarchy <Control-Up> { %W yview scroll -1 pages }
926 bind Hierarchy <Control-Down> { %W yview scroll 1 pages }
927 bind Hierarchy <Control-Left> { %W xview scroll -1 pages }
928 bind Hierarchy <Control-Right> { %W xview scroll 1 pages }
929 bind Hierarchy <Prior> { %W yview scroll -1 pages }
930 bind Hierarchy <Next> { %W yview scroll 1 pages }
931 bind Hierarchy <Control-Prior> { %W xview scroll -1 pages }
932 bind Hierarchy <Control-Next> { %W xview scroll 1 pages }
933 bind Hierarchy <Home> { %W xview moveto 0 }
934 bind Hierarchy <End> { %W xview moveto 1 }
935 bind Hierarchy <Control-slash> { Hierarchy:SelectAll [winfo parent %W] }
936 bind Hierarchy <Control-backslash> { [winfo parent %W] selection clear }
943 bind Hierarchy <B2-Motion> {
944 %W scan dragto $tkPriv(x) %y
947 # Hierarchy:BeginSelect --
949 # This procedure is typically invoked on button-1 presses. It begins
950 # the process of making a selection in the hierarchy. Its exact behavior
951 # depends on the selection mode currently in effect for the hierarchy;
952 # see the Motif documentation for details.
955 # w - The hierarchy widget.
956 # el - The element for the selection operation (typically the
957 # one under the pointer). Must be in numerical form.
959 ;proc Hierarchy:BeginSelect {w el} {
961 if {[catch {Hierarchy_index $w $el} el]} return
964 set tkPriv(hierarchyPrev) $el
967 # Hierarchy:Motion --
969 # This procedure is called to process mouse motion events while
970 # button 1 is down. It may move or extend the selection, depending
971 # on the hierarchy's selection mode.
974 # w - The hierarchy widget.
975 # el - The element under the pointer (must be a number).
977 ;proc Hierarchy:Motion {w el} {
979 if {[catch {Hierarchy_index $w $el} el] || \
980 [string match $el $tkPriv(hierarchyPrev)]} return
981 switch [Hierarchy_cget $w -selectmode] {
983 Hierarchy_selection $w clear 0 end
984 if {![catch {Hierarchy_selection $w set $el}]} {
985 set tkPriv(hierarchyPrev) $el
989 ## This happens when a double-1 occurs and all the index boxes
991 if {[catch {Hierarchy_selection $w includes \
992 $tkPriv(hierarchyPrev)} inc]} {
993 set tkPriv(hierarchyPrev) [Hierarchy_index $w $el]
997 Hierarchy_selection $w set $el
999 Hierarchy_selection $w clear $el
1001 set tkPriv(hierarchyPrev) $el
1006 # Hierarchy:BeginExtend --
1008 # This procedure is typically invoked on shift-button-1 presses. It
1009 # begins the process of extending a selection in the hierarchy. Its
1010 # exact behavior depends on the selection mode currently in effect
1011 # for the hierarchy;
1014 # w - The hierarchy widget.
1015 # el - The element for the selection operation (typically the
1016 # one under the pointer). Must be in numerical form.
1018 ;proc Hierarchy:BeginExtend {w el} {
1019 if {[catch {Hierarchy_index $w $el} el]} return
1020 if {[string match multiple [$w cget -selectmode]]} {
1021 Hierarchy:Motion $w $el
1025 # Hierarchy:BeginToggle --
1027 # This procedure is typically invoked on control-button-1 presses. It
1028 # begins the process of toggling a selection in the hierarchy. Its
1029 # exact behavior depends on the selection mode currently in effect
1030 # for the hierarchy; see the Motif documentation for details.
1033 # w - The hierarchy widget.
1034 # el - The element for the selection operation (typically the
1035 # one under the pointer). Must be in numerical form.
1037 ;proc Hierarchy:BeginToggle {w el} {
1039 if {[catch {Hierarchy_index $w $el} el]} return
1040 if {[string match multiple [$w cget -selectmode]]} {
1041 $w selection anchor $el
1042 if {[$w selection includes $el]} {
1043 $w selection clear $el
1045 $w selection set $el
1047 set tkPriv(hierarchyPrev) $el
1051 # Hierarchy:AutoScan --
1052 # This procedure is invoked when the mouse leaves an entry window
1053 # with button 1 down. It scrolls the window up, down, left, or
1054 # right, depending on where the mouse left the window, and reschedules
1055 # itself as an "after" command so that the window continues to scroll until
1056 # the mouse moves back into the window or the mouse button is released.
1059 # w - The hierarchy widget.
1061 ;proc Hierarchy:AutoScan {w} {
1063 if {![winfo exists $w]} return
1066 if {$y>=[winfo height $w]} {
1067 $w yview scroll 1 units
1069 $w yview scroll -1 units
1070 } elseif {$x>=[winfo width $w]} {
1071 $w xview scroll 2 units
1073 $w xview scroll -2 units
1077 #Hierarchy:Motion $w [$w index @$x,$y]
1078 set tkPriv(afterId) [after 50 Hierarchy:AutoScan $w]
1081 # Hierarchy:SelectAll
1083 # This procedure is invoked to handle the "select all" operation.
1084 # For single and browse mode, it just selects the root element.
1085 # Otherwise it selects everything in the widget.
1088 # w - The hierarchy widget.
1090 ;proc Hierarchy:SelectAll w {
1091 if {[regexp (browse|single) [$w cget -selectmode]]} {
1093 $w selection set root
1095 $w selection set all
1099 #------------------------------------------------------------
1100 # Default nodelook methods
1101 #------------------------------------------------------------
1103 ;proc Hierarchy:FileLook { w np isopen } {
1105 set path [eval file join $np]
1106 set file [lindex $np end]
1108 if {[file readable $path]} {
1109 if {[file isdirectory $path]} {
1111 ## We know that kids will always be set by the time
1112 ## the isopen is set to 1
1113 if {[string compare $data(:$np,kids) {}]} {
1114 set bmp bmp:dir_minus
1119 set bmp bmp:dir_plus
1122 ## NOTE: accurate, but very expensive
1123 if {[string compare [Hierarchy:FileList $w $np] {}]} {
1124 if {$isopen} {set bmp bmp:dir_minus} {set bmp bmp:dir_plus}
1131 } elseif {[string compare $data(-showparent) {}] && \
1132 [string match $data(-showparent) $file]} {
1137 if {[file isdirectory $path]} {set bmp bmp:dir}
1139 return [list $file $data(-font) $bmp $fg]
1142 ## Hierarchy:FileList
1143 # ARGS: w hierarchy widget
1145 # Returns: directory listing
1147 ;proc Hierarchy:FileList { w np } {
1149 if {[catch "cd \[file join $np\]"]} {
1155 if {!$data(-showfiles)} { append str / }
1156 if {$data(-showall) && [string match unix $tcl_platform(platform)]} {
1157 ## NOTE: Use of non-core lremove
1158 if {[catch {lsort [concat [glob -nocomplain $str] \
1159 [lremove [glob -nocomplain .$str] {. ..}]]} list]} {
1163 ## The extra catch is necessary for unusual error conditions
1164 if {[catch {lsort [glob -nocomplain $str]} list]} {
1168 set root $data(-root)
1169 if {[string compare {} $data(-showparent)] && \
1170 [string match $root $np]} {
1171 if {![regexp {^(.:)?/+$} $root] && \
1172 [string compare [file dir $root] $root]} {
1173 set list [linsert $list 0 $data(-showparent)]
1181 ;proc Hierarchy:FileActivate { w np isopen } {
1183 set path [eval file join $np]
1184 if {[file isdirectory $path]} return
1185 if {[string compare $data(-showparent) {}] && \
1186 [string match $data(-showparent) [lindex $np end]]} {
1187 $w config -root [file dir $data(-root)]
1191 ;proc Hierarchy:WidgetLook { W np isopen } {
1193 if {$data(-showall)} {
1194 set w [lindex $np end]
1197 regsub {\.\.} $w {.} w
1199 if {[string compare [winfo children $w] {}]} {set fg blue} {set fg black}
1200 return [list "\[[winfo class $w]\] [lindex $np end]" {} {} $fg]
1203 ;proc Hierarchy:WidgetList { W np } {
1205 if {$data(-showall)} {
1206 set w [lindex $np end]
1209 regsub {\.\.} $w {.} w
1212 foreach i [lsort [winfo children $w]] {
1213 if {$data(-showall)} {
1216 lappend kids [file extension $i]
1222 ;proc Hierarchy:WidgetActivate { w np isopen } {}
1227 image create bitmap bmp:dir -data {#define folder_width 16
1228 #define folder_height 12
1229 static char folder_bits[] = {
1230 0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40,
1231 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
1232 image create bitmap bmp:dir_plus -data {#define folder_plus_width 16
1233 #define folder_plus_height 12
1234 static char folder_plus_bits[] = {
1235 0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x82, 0x40,
1236 0x82, 0x40, 0xe2, 0x43, 0x82, 0x40, 0x82, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
1237 image create bitmap bmp:dir_minus -data {#define folder_minus_width 16
1238 #define folder_minus_height 12
1239 static char folder_minus_bits[] = {
1240 0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40,
1241 0x02, 0x40, 0xe2, 0x43, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
1242 image create bitmap bmp:up -data {#define up.xbm_width 16
1243 #define up.xbm_height 12
1244 static unsigned char up.xbm_bits[] = {
1245 0x00, 0x00, 0x10, 0x00, 0x38, 0x00, 0x7c, 0x00, 0xfe, 0x00, 0x38, 0x00,
1246 0x38, 0x00, 0x38, 0x00, 0xf8, 0x7f, 0xf0, 0x7f, 0xe0, 0x7f, 0x00, 0x00};}
1247 image create bitmap bmp:text -data {#define text_width 15
1248 #define text_height 14
1249 static char text_bits[] = {
1250 0xff,0x07,0x01,0x0c,0x01,0x04,0x01,0x24,0xf9,0x7d,0x01,0x78,0x01,0x40,0xf1,
1251 0x41,0x01,0x40,0x01,0x40,0xf1,0x41,0x01,0x40,0x01,0x40,0xff,0x7f};}