@r-universe/webr 2023.6.11 → 2023.6.21

package/dist/vfs/usr/lib/R/library/tcltk/exec/hierarchy.tcl

@@ -0,0 +1,1271 @@
+##
+## Layout routines taken from oooold code, author unkown.
+## Copyright 1995-1998 Jeffrey Hobbs, jeff.hobbs@acm.org
+##
+## Last Update: 28 June 1997
+##
+package require Widget 2.0
+package provide Hierarchy 2.0
+
+##-----------------------------------------------------------------------
+## PROCEDURE(S)
+##	hierarchy, hierarchy_dir, hierarchy_widget
+##
+## ARGUMENTS && DESCRIPTION
+##
+## hierarchy <window pathname> <options>
+##	Implements a hierarchical listbox
+## hierarchy_dir <window pathname> <options>
+##	Implements a hierarchical listbox using a directory view structure
+##	for the default methods
+## hierarchy_widget <window pathname> <options>
+##	Implements a hierarchical listbox using a widget view structure
+##	for the default methods
+##
+## OPTIONS
+##	(Any canvas option may be used with a hierarchy)
+##
+## -autoscrollbar TCL_BOOLEAN			DEFAULT: 1
+##	Determines whether scrollbars automagically pop-up or
+##	are permanently there.
+##
+## -browsecmd procedure				DEFAULT: noop
+##	A command which the widget will execute when the node is expanded
+##	to retrieve the children of a node.  The widget and node path are
+##	appended to the command as a list of node names which
+##	form a path to the node from the root.  Thus the first
+##	element of this list will always be the root node.
+##
+## -command procedure				DEFAULT: noop
+##	A command which the widget will execute when the node is toggled.
+##	The name of the widget, the node path, and whether the children of
+##	the node are showing (0/1) is appended to the procedure args.
+##
+## -decoration TCL_BOOLEAN			DEFAULT: 1
+##	If this is true, the "tree" lines are drawn.
+##
+## -expand #					DEFAULT: 1
+##	an integer value for an initial depth to expand to.
+##
+## -font fontname				DEFAULT: fixed
+##	The default font used for the text.
+##
+## -foreground color				DEFAULT: black
+##	The default foreground color used for text of unselected nodes.
+##
+## -ipad #					DEFAULT: 3
+##	The internal space added between the image and the text for a
+##	given node.
+##
+## -nodelook procedure				DEFAULT: noop
+##	A command the widget will execute to get the look of a node.
+##	The node is appended to the command as a list of
+##	node-names which form a path to the node from the root.
+##	Thus the first element of this list will always be the
+##	root node.  Also appended is a 
+##	boolean value which indicates whether the node's children
+##	are currently displayed.  This allows the node's
+##	look to change if it is "opened" or "closed".
+##
+##	This command must return a 4-tuple list containing:
+##		0. the text to display at the node
+##		1. the font to use for the text
+##		2. an image to display
+##		3. the foreground color to use for the node
+##	If no font (ie. {}) is specified then
+##	the value from -font is used.  If no image is specified
+##	then no image is displayed.
+##	The default is a command to which produces a nice look
+##	for a file manager.  
+##
+## -paddepth #					DEFAULT: 12
+##	The indent space added for child branches.
+##
+## -padstack #					DEFAULT: 2
+##	The space added between two rows
+##
+## -root rootname				DEFAULT: {}
+##  	The name of the root node of the tree.  Each node
+##	name must be unique amongst the children of each node.
+##
+## -selectbackground color			DEFAULT: red
+##	The default background color used for the text of selected nodes.
+##
+## -selectmode (single|browse|multiple)		DEFAULT: browse
+##	Like listbox modes, "multiple" is a mix of multiple && extended.
+##
+## -showall TCL_BOOLEAN				DEFAULT: 0
+##	For directory nodelook, also show Unix '.' (hidden) files/dirs.
+##
+## -showfiles TCL_BOOLEAN			DEFAULT: 0
+##	Show files as well as directories.
+##
+## -showparent string				DEFAULT: {}
+##	For hierarchy_dir nodelook, if string != {}, then it will show that
+##	string which will reset the root node to its parent.
+##
+## METHODS
+##	These are the methods that the hierachical listbox object recognizes.
+##	(ie - hierachy .h ; .h <method> <args>)
+##	Any unique substring is acceptable
+##
+## configure ?option? ?value option value ...?
+## cget option
+##	Standard tk widget routines.
+##
+## close index
+##	Closes the specified index (will trigger -command).
+##
+## curselection
+##	Returns the indices of the selected items.  This differs from the
+##	listbox method because indices here have no implied order.
+##
+## get index ?index ...?
+##	Returns the node paths of the items referenced.  Ranges are not
+##	allowed.  Index specification is like that allowed by the index
+##	method.
+##
+## qget index ?index ...?
+##	As above, but the indices must be that of the item (as returned
+##	by the index or curselection method).
+##
+## index index
+##	Returns the hierarchy numerical index of the item (the numerical
+##	index has no implied order relative to the list items).  index
+##	may be of the form:
+##
+##	number - Specifies the element as a numerical index.
+##	root   - specifies the root item.
+##	string - Specifis an item that has that text in it's node.
+##	@x,y   - Indicates the element that covers the point in
+##		the listbox window specified by x and y (in pixel
+##		coordinates).  If no element covers that point,
+##		then the closest element to that point is used.
+##
+## open index
+##	Opens the specified index (will trigger -command).
+##
+## see index
+##	Ensures that the item specified by the index is viewable.
+##
+## refresh
+##	Refreshes all open nodes
+##
+## selection option arg
+##	This works like the listbox selection method with the following
+##	exceptions:
+##
+##	The selection clear option can take multiple indices, but not a range.
+##	No arguments to clear means clear all the selected elements.
+##
+##	The selection set option can take multiple indices, but not a range.
+##	The key word 'all' sets the selection for all elements.
+##
+## size
+##	Returns the number of items in the hierarchical listbox.
+##
+## toggle index
+##	Toggles (open or closed) the item specified by index
+##	(triggers -command).
+##
+## BINDINGS
+##	Most Button-1 bindings on the hierarchy work in the same manner
+##	as those for the listbox widget, as defined by the selectmode.
+##	Those that vary are listed below:
+##
+## <Double-Button-1>
+##	Toggles a node in the hierarchy
+##
+## NAMESPACE & STATE
+##	The megawidget creates a global array with the classname, and a
+## global array which is the name of each megawidget is created.  The latter
+## array is deleted when the megawidget is destroyed.
+##	Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used.
+## Other procs that begin with $CLASSNAME are private.  For each widget,
+## commands named .$widgetname and $CLASSNAME$widgetname are created.
+##
+##-----------------------------------------------------------------------
+
+# Create this to make sure there are registered in auto_mkindex
+# these must come before the [widget create ...]
+proc Hierarchy args {}
+proc hierarchy args {}
+
+## In general, we cannot use $data(basecmd) in the construction, but the
+## scrollbar commands won't be called until after it really exists as a
+## proper command
+widget create Hierarchy -type frame -base canvas -components {
+    {base canvas canvas {-relief sunken -bd 1 -highlightthickness 1 \
+	    -yscrollcommand [list $data(yscrollbar) set] \
+	    -xscrollcommand [list $data(xscrollbar) set]}}
+    {scrollbar xscrollbar sx {-orient h -bd 1 -highlightthickness 1\
+	    -command [list $data(basecmd) xview]}}
+    {scrollbar yscrollbar sy {-orient v -bd 1 -highlightthickness 1\
+	    -command [list $data(basecmd) yview]}}
+} -options {
+    {-autoscrollbar	autoScrollbar	AutoScrollbar	1}
+    {-browsecmd		browseCmd	BrowseCmd	{}}
+    {-command		command		Command		{}}
+    {-decoration	decoration	Decoration	1}
+    {-expand		expand		Expand		1}
+    {-font		font		Font		fixed}
+    {-foreground	foreground	Foreground	black}
+    {-ipad		ipad		Ipad		3}
+    {-nodelook		nodeLook	NodeLook	{}}
+    {-paddepth		padDepth	PadDepth	12}
+    {-padstack		padStack	PadStack	2}
+    {-root		root		Root		{}}
+    {-selectmode	selectMode	SelectMode	browse}
+    {-selectbackground	selectBackground SelectBackground red}
+    {-state		state		State		normal}
+
+    {-showall		showAll		ShowAll		0}
+    {-showparent	showParent	ShowParent	{}}
+    {-showfiles		showFiles	ShowFiles	0}
+}
+
+proc hierarchy_dir {w args} {
+    uplevel [list hierarchy $w -root [pwd] \
+	    -nodelook  {namespace inscope ::Widget::Hierarchy FileLook} \
+	    -command   {namespace inscope ::Widget::Hierarchy FileActivate} \
+	    -browsecmd {namespace inscope ::Widget::Hierarchy FileList}] \
+	    $args
+}
+
+proc hierarchy_widget {w args} {
+    uplevel [list hierarchy $w -root . \
+	    -nodelook  {namespace inscope ::Widget::Hierarchy WidgetLook} \
+	    -command   {namespace inscope ::Widget::Hierarchy WidgetActivate} \
+	    -browsecmd {namespace inscope ::Widget::Hierarchy WidgetList}] \
+	    $args
+}
+
+namespace eval ::Widget::Hierarchy {;
+
+;proc construct w {
+    upvar \#0 [namespace current]::$w data
+
+    ## Private variables
+    array set data [list \
+	    hasnodelook	0 \
+	    halfpstk	[expr $data(-padstack)/2] \
+	    width	400 \
+	    ]
+
+    grid $data(canvas) $data(yscrollbar) -sticky news
+    grid $data(xscrollbar) -sticky ew
+    grid columnconfig $w 0 -weight 1
+    grid rowconfig $w 0 -weight 1
+    bind $data(canvas) <Configure> [namespace code [list Resize $w %w %h]]
+}
+
+;proc init w {
+    upvar \#0 [namespace current]::$w data
+
+    set data(:$data(-root),showkids) 0
+    ExpandNodeN $w $data(-root) $data(-expand)
+    if {[catch {$w see $data(-root)}]} {
+	$data(basecmd) configure -scrollregion {0 0 1 1}
+    }
+}
+
+;proc configure {w args} {
+    upvar \#0 [namespace current]::$w data
+
+    set truth {^(1|yes|true|on)$}
+    array set config { resize 0 root 0 showall 0 }
+    foreach {key val} $args {
+	switch -- $key {
+	    -autoscrollbar {
+		set val [regexp -nocase $truth $val]
+		if {$val} {
+		    set config(resize) 1
+		} else {
+		    grid $data(xscrollbar)
+		    grid $data(yscrollbar)
+		}
+	    }
+	    -decoration	{ set val [regexp -nocase $truth $val] }
+	    -padstack	{ set data(halfpstk) [expr {$val/2}] }
+	    -nodelook	{
+		## We set this special bool val because it saves some
+		## computation in ExpandNode, a deeply nested proc
+		set data(hasnodelook) [string compare $val {}]
+	    }
+	    -root		{
+		if {[info exists data(:$data(-root),showkids)]} {
+		    ## All data about items and selection should be
+		    ## cleared and the items deleted
+		    foreach name [concat [array names data :*] \
+			    [array names data S,*]] {unset data($name)}
+		    $data(basecmd) delete all
+		    set data(-root) $val
+		    set config(root) 1
+		    ## Avoid setting data($key) below
+		    continue
+		}
+	    }
+	    -selectbackground {
+		foreach i [array names data S,*] {
+		    $data(basecmd) itemconfigure [string range $i 2 end] \
+			    -fill $val
+		}
+	    }
+	    -state	{
+		if {![regexp {^(normal|disabled)$} $val junk val]} {
+		    return -code error "bad state value \"$val\":\
+			    must be normal or disabled"
+		}
+	    }
+	    -showall	-
+	    -showfiles	{
+		set val [regexp -nocase $truth $val]
+		if {$val == $data($key)} continue
+		set config(showall) 1
+	    }
+	}
+	set data($key) $val
+    }
+    if {$config(root)} {
+	set data(:$val,showkids) 0
+	ExpandNodeN $w $val $data(-expand)
+    } elseif {$config(showall) && [info exists data(:$data(-root),showkids)]} {
+	_refresh $w
+    } elseif {$config(resize)} {
+	Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)]
+    }
+}
+
+## Cryptic source code arguments explained:
+## (these, or a similar form, might appear as variables later)
+## np   == node path
+## cnp  == changed np
+## knp  == kids np
+## xcnp == extra cnp
+
+;proc _index { w idx } {
+    upvar \#0 [namespace current]::$w data
+    set c $data(basecmd)
+    if {[string match all $idx]} {
+	return [$c find withtag box]
+    } elseif {[regexp {^(root|anchor)$} $idx]} {
+	return [$c find withtag box:$data(-root)]
+    }
+    foreach i [$c find withtag $idx] {
+	if {[string match rec* [$c type $i]]} { return $i }
+    }
+    if {[regexp {@(-?[0-9]+),(-?[0-9]+)} $idx z x y]} {
+	return [$c find closest [$w canvasx $x] [$w canvasy $y] 1 text]
+    }
+    foreach i [$c find withtag box:[lindex $idx 0]] { return $i }
+    return -code error "bad hierarchy index \"$idx\":\
+	    must be current, @x,y, a number, or a node name"
+}
+
+;proc _selection { w args } {
+    if {[string match {} $args]} {
+	return -code error \
+		"wrong \# args: should be \"$w selection option args\""
+    }
+    upvar \#0 [namespace current]::$w data
+    set err [catch {_index $w [lindex $args 1]} idx]
+    switch -glob -- [lindex $args 0] {
+	an* {
+	    ## anchor
+	    ## stubbed out - too complicated to support
+	}
+	cl* {
+	    ## clear
+	    set c $data(basecmd)
+	    if {$err} {
+		foreach arg [array names data S,*] { unset data($arg) }
+		$c itemconfig box -fill {}
+	    } else {
+		catch {unset data(S,$idx)}
+		$c itemconfig $idx -fill {}
+		foreach idx [lrange $args 2 end] {
+		    if {[catch {_index $w $idx} idx]} {
+			catch {unset data(S,$idx)}
+			$c itemconfig $idx -fill {}
+		    }
+		}
+	    }
+	}
+	in* {
+	    ## includes
+	    if {$err} {
+		if {[llength $args]==2} {
+		    return -code error $idx
+		} else {
+		    return -code error "wrong \# args:\
+			    should be \"$w selection includes index\""
+		}
+	    }
+	    return [info exists data(S,$idx)]
+	}
+	se* {
+	    ## set
+	    if {$err} {
+		if {[string compare {} $args]} return
+		return -code error "wrong \# args:\
+			should be \"$w selection set index ?index ...?\""
+	    } else {
+		set c $data(basecmd); set col $data(-selectbackground)
+		if {[string match all [lindex $args 1]]} {
+		    foreach i $idx { set data(S,$i) 1 }
+		    $c itemconfig box -fill $col
+		} else {
+		    set data(S,$idx) 1
+		    $c itemconfig $idx -fill $col
+		    foreach idx [lrange $args 2 end] {
+			if {![catch {_index $w $idx} idx]} {
+			    set data(S,$idx) 1
+			    $c itemconfig $idx -fill $col
+			}
+		    }
+		}
+	    }
+	}
+	default {
+	    return -code error "bad selection option \"[lindex $args 0]\":\
+		    must be clear, includes, set"
+	}
+    }
+}
+
+;proc _curselection {w} {
+    upvar \#0 [namespace current]::$w data
+
+    set res {}
+    foreach i [array names data S,*] { lappend res [string range $i 2 end] }
+    return $res
+}
+
+;proc _get {w args} {
+    upvar \#0 [namespace current]::$w data
+
+    set nps {}
+    foreach arg $args {
+	if {![catch {_index $w $arg} idx] && \
+		[string compare {} $idx]} {
+	    set tags [$data(basecmd) gettags $idx]
+	    if {[set i [lsearch -glob $tags box:*]]>-1} {
+		lappend nps [string range [lindex $tags $i] 4 end]
+	    }
+	}
+    }
+    return $nps
+}
+
+;proc _qget {w args} {
+    upvar \#0 [namespace current]::$w data
+
+    ## Quick get.  Avoids expensive _index call
+    set nps {}
+    foreach arg $args {
+	set tags [$data(basecmd) itemcget $arg -tags]
+	if {[set i [lsearch -glob $tags box:*]]>-1} {
+	    lappend nps [string range [lindex $tags $i] 4 end]
+	}
+    }
+    return $nps
+}
+
+;proc _see {w args} {
+    upvar \#0 [namespace current]::$w data
+
+    if {[catch {_index $w $args} idx]} {
+	return -code error $idx
+    } elseif {[string compare {} $idx]} {
+	set c $data(basecmd)
+	foreach {x y x1 y1} [$c bbox $idx] {top btm} [$c yview] {
+	    set stk [lindex [$c cget -scrollregion] 3]
+	    set pos [expr (($y1+$y)/2.0)/$stk - ($btm-$top)/2.0]
+	}
+	$c yview moveto $pos
+    }
+}
+
+;proc _refresh {w} {
+    upvar \#0 [namespace current]::$w data
+
+    array set expanded [array get data ":*,showkids"]
+    foreach i [concat [array names data :*] \
+	    [array names data S,*]] {unset data($i)}
+    $data(basecmd) delete all
+    ## -dec makes it sort in root-first order
+    foreach i [lsort -ascii -decreasing [array names expanded]] {
+	if {$expanded($i)} {
+	    regexp {^:(.*),showkids$} $i junk np
+	    ## Quick way to remove the last element of a list
+	    set prnt [lreplace $np end end]
+	    ## checks to get rid of dead, previously opened nodes
+	    if {[string match {} $prnt] || ([info exists data(:$prnt,kids)] \
+		    && [lsearch -exact $data(:$prnt,kids) \
+		    [lindex $np end]] != -1)} {
+		set data($i) 0
+		ExpandNode $w $np
+	    }
+	}
+    }
+    Redraw $w $data(-root)
+    Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)]
+}
+
+;proc _size {w} {
+    upvar \#0 [namespace current]::$w data
+    return [llength [$data(basecmd) find withtag box]]
+}
+
+## This will be the one called by <Double-Button-1> on the canvas,
+## if -state is normal, so we have to make sure that $w is correct.
+##
+;proc _toggle { w index } {
+    toggle $w $index toggle
+}
+
+;proc _close { w index } {
+    toggle $w $index close
+}
+
+;proc _open { w index } {
+    toggle $w $index open
+}
+
+;proc toggle { w index which } {
+    if {[string compare Hierarchy [winfo class $w]]} {
+	set w [winfo parent $w]
+    }
+    upvar \#0 [namespace current]::$w data
+
+    if {[string match {} [set np [_get $w $index]]]} return
+    set np [lindex $np 0]
+
+    set old [$data(basecmd) cget -cursor]
+    $data(basecmd) config -cursor watch
+    update
+    switch $which {
+	close	{ CollapseNodeAll $w $np }
+	open	{ ExpandNodeN $w $np 1 }
+	toggle	{
+	    if {$data(:$np,showkids)} {
+		CollapseNodeAll $w $np
+	    } else {
+		ExpandNodeN $w $np 1
+	    }
+	}
+    }
+    if {[string compare {} $data(-command)]} {
+	uplevel \#0 $data(-command) [list $w $np $data(:$np,showkids)]
+    }
+    $data(basecmd) config -cursor $old
+    return
+}
+
+;proc Resize { w wid hgt } {
+    upvar \#0 [namespace current]::$w data
+    set c $data(basecmd)
+    if {[string compare {} [set box [$c bbox image text]]]} {
+	set X [lindex $box 2]
+	if {$data(-autoscrollbar)} {
+	    set Y [lindex $box 3]
+	    if {$wid>$X} {
+		set X $wid
+		grid remove $data(xscrollbar)
+	    } else {
+		grid $data(xscrollbar)
+	    }
+	    if {$hgt>$Y} {
+		set Y $hgt
+		grid remove $data(yscrollbar)
+	    } else {
+		grid $data(yscrollbar)
+	    }
+	    $c config -scrollregion "0 0 $X $Y"
+	}
+	## This makes full width highlight boxes
+	## data(width) is the default width of boxes
+	if {$X>$data(width)} {
+	    set data(width) $X
+	    foreach b [$c find withtag box] {
+		foreach {x y x1 y1} [$c coords $b] { $c coords $b 0 $y $X $y1 }
+	    }
+	}
+    } elseif {$data(-autoscrollbar)} {
+	grid remove $data(xscrollbar) $data(yscrollbar)
+    }
+}
+
+;proc CollapseNodeAll { w np } {
+    if {[CollapseNode $w $np]} {
+	upvar \#0 [namespace current]::$w data
+	Redraw $w $np
+	DiscardChildren $w $np
+	Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)]
+    }
+}
+
+;proc ExpandNodeN { w np n } {
+    upvar \#0 [namespace current]::$w data
+    if {[ExpandNodeN_aux $w $np $n] || \
+	    ([string compare $data(-root) {}] && \
+	    ![string compare $data(-root) $np])} {
+	Redraw $w $np
+	Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)]
+    }
+}
+
+;proc ExpandNodeN_aux { w np n } {
+    if {![ExpandNode $w $np]} { return 0 }
+    if {$n==1} { return 1 }
+    incr n -1
+    upvar \#0 [namespace current]::$w data
+    foreach k $data(:$np,kids) {
+	ExpandNodeN_aux $w "$np [list $k]" $n
+    }
+    return 1
+}
+
+########################################################################
+##
+## Private routines to collapse and expand a single node w/o redrawing
+## Most routines return 0/1 to indicate if any change has occurred
+##
+########################################################################
+
+;proc ExpandNode { w np } {
+    upvar \#0 [namespace current]::$w data
+
+    if {$data(:$np,showkids)} { return 0 }
+    set data(:$np,showkids) 1
+    if {![info exists data(:$np,kids)]} {
+	if {[string compare $data(-browsecmd) {}]} {
+	    set data(:$np,kids) [uplevel \#0 $data(-browsecmd) [list $w $np]]
+	} else {
+	    set data(:$np,kids) {}
+	}
+    }
+    if $data(hasnodelook) {
+	set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 1]]
+    } else {
+	set data(:$np,look) {}
+    }
+    if {[string match {} $data(:$np,kids)]} {
+	## This is needed when there are no kids to make sure the
+	## look of the node will be updated appropriately
+	foreach {txt font img fg} $data(:$np,look) {
+	    lappend tags box:$np box $np
+	    set c $data(basecmd)
+	    if {[string compare $img {}]} {
+		## Catch just in case the image doesn't exist
+		catch {
+		    $c itemconfigure img:$np -image $img
+		    lappend tags $img
+		}
+	    }
+	    if {[string compare $txt {}]} {
+		if {[string match {} $font]} { set font $data(-font) }
+		if {[string match {} $fg]}   { set fg $data(-foreground) }
+		$c itemconfigure txt:$np -fill $fg -text $txt -font $font
+		if {[string compare $np $txt]} { lappend tags $txt }
+	    }
+	    $c itemconfigure box:$np -tags $tags
+	    ## We only want to go through once
+	    break
+	}
+	return 0
+    }
+    foreach k $data(:$np,kids) {
+	set knp "$np [list $k]"
+	## Check to make sure it doesn't already exist,
+	## in case we are refreshing the node or something
+	if {![info exists data(:$knp,showkids)]} { set data(:$knp,showkids) 0 }
+	if $data(hasnodelook) {
+	    set data(:$knp,look) [uplevel \#0 $data(-nodelook) [list $w $knp 0]]
+	} else {
+	    set data(:$knp,look) {}
+	}
+    }
+    return 1
+}
+
+;proc CollapseNode { w np } {
+    upvar \#0 [namespace current]::$w data
+    if {!$data(:$np,showkids)} { return 0 }
+    set data(:$np,showkids) 0
+    if {[string match {} $data(:$np,kids)]} { return 0 }
+    if {[string compare $data(-nodelook) {}]} {
+	set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 0]]
+    } else {
+	set data(:$np,look) {}
+    }
+    foreach k $data(:$np,kids) { CollapseNode $w "$np [list $k]" }
+    return 1
+}
+
+;proc DiscardChildren { w np } {
+    upvar \#0 [namespace current]::$w data
+    if {[info exists data(:$np,kids)]} {
+	foreach k $data(:$np,kids) {
+	    set knp "$np [list $k]"
+	    $data(basecmd) delete img:$knp txt:$knp box:$knp
+	    foreach i {showkids look stkusg stack iwidth offset} {
+		catch {unset data(:$knp,$i)}
+	    }
+	    DiscardChildren $w $knp
+	}
+	unset data(:$np,kids)
+    }
+}
+
+## REDRAW mechanism
+## 2 parts:	recompute offsets of all children from changed node path
+##		then redraw children based on their offsets and look
+##
+;proc Redraw { w cnp } {
+    upvar \#0 [namespace current]::$w data
+
+    set c $data(basecmd)
+    # When a node changes, the positions of a whole lot of things
+    # change.  The size of the scroll region also changes.
+    $c delete decor
+
+    # Calculate the new offset locations of everything
+    Recompute $w $data(-root) [lrange $cnp 1 end]
+
+    # Next recursively move all the bits around to their correct positions.
+    # We choose an initial point (4,4) to begin at.
+    Redraw_aux $w $data(-root) 4 4
+
+    # Necessary to make sure find closest gets the right item
+    # ordering: image > text > box
+    after idle "catch { [list $c] raise image text; [list $c] lower box text }"
+}
+
+## RECOMPUTE recurses through the tree working out the relative offsets
+## of children from their parents in terms of stack values.  
+##
+## "cnp" is either empty or a node name which indicates where the only
+## changes have occured in the hierarchy since the last call to Recompute.
+## This is used because when a node is toggled on/off deep in the
+## hierarchy then not all the positions of items need to be recomputed.
+## The only ones that do are everything below the changed node (of
+## course), and also everything which might depend on the stack usage of
+## that node (i.e. everything above it).  Specifically the usages of the
+## changed node's siblings do *not* need to be recomputed.
+##
+;proc Recompute { w np cnp } {
+    upvar \#0 [namespace current]::$w data
+    # If the cnp now has only one element then
+    # it must be one of the children of the current node.
+    # We do not need to Recompute the usages of its siblings if it is.
+    set cnode_is_child [expr {[llength $cnp]==1}]
+    if {$cnode_is_child} {
+	set cnode [lindex $cnp 0]
+    } else {
+	set xcnp [lrange $cnp 1 end]
+    }
+    
+    # Run through the children, recursively calculating their usage of
+    # stack real-estate, and allocating an intial placement for each child
+    #
+    # Values do not need to be recomputed for siblings of the changed
+    # node and their descendants.  For the cnode itself, in the
+    # recursive call we set the value of cnode to {} to prevent
+    # any further cnode checks.
+
+    set children_stack 0
+    if {$data(:$np,showkids)} { 
+	foreach k $data(:$np,kids) {
+	    set knp "$np [list $k]"
+	    set data(:$knp,offset) $children_stack
+	    if {$cnode_is_child && [string match $cnode $k]} {
+		set data(:$knp,stkusg) [Recompute $w $knp {}]
+	    } elseif {!$cnode_is_child} {
+		set data(:$knp,stkusg) [Recompute $w $knp $xcnp]
+	    }
+	    incr children_stack $data(:$knp,stkusg)
+	    incr children_stack $data(-padstack)
+	}
+    }
+
+    ## Make the image/text if they don't exist.
+    ## Positioning occurs in Redraw_aux.
+    ## And calculate the stack usage of our little piece of the world.
+    set img_height 0; set img_width 0; set txt_width 0; set txt_height 0
+
+    foreach {txt font img fg} $data(:$np,look) {
+	lappend tags box:$np box $np
+	set c $data(basecmd)
+	if {[string compare $img {}]} {
+	    if {[string match {} [$c find withtag img:$np]]} {
+		$c create image 0 0 -anchor nw -tags [list img:$np image]
+	    }
+	    ## Catch just in case the image doesn't exist
+	    catch {
+		$c itemconfigure img:$np -image $img
+		lappend tags $img
+		foreach {x y img_width img_height} [$c bbox img:$np] {
+		    incr img_width -$x; incr img_height -$y
+		}
+	    }
+	}
+	if {[string compare $txt {}]} {
+	    if {[string match {} [$c find withtag txt:$np]]} {
+		$c create text 0 0 -anchor nw -tags [list txt:$np text]
+	    }
+	    if {[string match {} $font]} { set font $data(-font) }
+	    if {[string match {} $fg]}   { set fg $data(-foreground) }
+	    $c itemconfigure txt:$np -fill $fg -text $txt -font $font
+	    if {[string compare $np $txt]} { lappend tags $txt }
+	    foreach {x y txt_width txt_height} [$c bbox txt:$np] {
+		incr txt_width -$x; incr txt_height -$y
+	    }
+	}
+	if {[string match {} [$c find withtag box:$np]]} {
+	    $c create rect 0 0 1 1 -tags [list box:$np box] -outline {}
+	}
+	$c itemconfigure box:$np -tags $tags
+	## We only want to go through this once
+	break
+    }
+
+    set stack [expr {$txt_height>$img_height?$txt_height:$img_height}]
+
+    # Now reposition the children downward by "stack"
+    set overall_stack [expr {$children_stack+$stack}]
+
+    if {$data(:$np,showkids)} { 
+	set off [expr {$stack+$data(-padstack)}]
+	foreach k $data(:$np,kids) {
+	    set knp "$np [list $k]"
+	    incr data(:$knp,offset) $off
+	}
+    }
+    # remember some facts for locating the image and drawing decor
+    array set data [list :$np,stack $stack :$np,iwidth $img_width]
+
+    return $overall_stack
+}
+
+;proc Redraw_aux {w np deppos stkpos} {
+    upvar \#0 [namespace current]::$w data
+
+    set c $data(basecmd)
+    $c coords img:$np $deppos $stkpos
+    $c coords txt:$np [expr {$deppos+$data(:$np,iwidth)+$data(-ipad)}] $stkpos
+    $c coords box:$np 0 [expr {$stkpos-$data(halfpstk)}] \
+	    $data(width) [expr {$stkpos+$data(:$np,stack)+$data(halfpstk)}]
+
+    if {!$data(:$np,showkids) || [string match {} $data(:$np,kids)]} return
+
+    set minkid_stkpos 100000
+    set maxkid_stkpos 0
+    set bar_deppos [expr {$deppos+$data(-paddepth)/2}]
+    set kid_deppos [expr {$deppos+$data(-paddepth)}]
+
+    foreach k $data(:$np,kids) {
+	set knp "$np [list $k]"
+	set kid_stkpos [expr {$stkpos+$data(:$knp,offset)}]
+	Redraw_aux $w $knp $kid_deppos $kid_stkpos
+	
+	if {$data(-decoration)} {
+	    if {$kid_stkpos<$minkid_stkpos} {set minkid_stkpos $kid_stkpos}
+	    set kid_stkpos [expr {$kid_stkpos+$data(:$knp,stack)/2}]
+	    if {$kid_stkpos>$maxkid_stkpos} {set maxkid_stkpos $kid_stkpos}
+	    
+	    $c create line $bar_deppos $kid_stkpos $kid_deppos $kid_stkpos \
+		    -width 1 -tags decor
+	}
+    }
+    if {$data(-decoration)} {
+	$c create line $bar_deppos $minkid_stkpos $bar_deppos $maxkid_stkpos \
+		-width 1 -tags decor
+    }
+}
+
+
+##
+## DEFAULT BINDINGS FOR HIERARCHY
+##
+## Since we give no border to the frame, all Hierarchy bindings
+## will always register on the canvas widget
+##
+bind Hierarchy <Double-Button-1> {
+    set w [winfo parent %W]
+    if {[string match normal [$w cget -state]]} {
+	$w toggle @%x,%y
+    }
+}
+bind Hierarchy <ButtonPress-1> {
+    if {[winfo exists %W]} {
+	namespace eval ::Widget::Hierarchy \
+		[list BeginSelect [winfo parent %W] @%x,%y]
+    }
+}
+bind Hierarchy <B1-Motion> {
+    set tkPriv(x) %x
+    set tkPriv(y) %y
+    namespace eval ::Widget::Hierarchy [list Motion [winfo parent %W] @%x,%y]
+}
+bind Hierarchy <ButtonRelease-1> { tkCancelRepeat }
+bind Hierarchy <Shift-1>   [namespace code \
+	{ BeginExtend [winfo parent %W] @%x,%y }]
+bind Hierarchy <Control-1> [namespace code \
+	{ BeginToggle [winfo parent %W] @%x,%y }]
+bind Hierarchy <B1-Leave> {
+    set tkPriv(x) %x
+    set tkPriv(y) %y
+    namespace eval ::Widget::Hierarchy [list AutoScan [winfo parent %W]]
+}
+bind Hierarchy <B1-Enter>	{ tkCancelRepeat }
+
+## Should reserve L/R U/D for traversing nodes
+bind Hierarchy <Up>		{ %W yview scroll -1 units }
+bind Hierarchy <Down>		{ %W yview scroll  1 units }
+bind Hierarchy <Left>		{ %W xview scroll -1 units }
+bind Hierarchy <Right>		{ %W xview scroll  1 units }
+
+bind Hierarchy <Control-Up>	{ %W yview scroll -1 pages }
+bind Hierarchy <Control-Down>	{ %W yview scroll  1 pages }
+bind Hierarchy <Control-Left>	{ %W xview scroll -1 pages }
+bind Hierarchy <Control-Right>	{ %W xview scroll  1 pages }
+bind Hierarchy <Prior>		{ %W yview scroll -1 pages }
+bind Hierarchy <Next>		{ %W yview scroll  1 pages }
+bind Hierarchy <Control-Prior>	{ %W xview scroll -1 pages }
+bind Hierarchy <Control-Next>	{ %W xview scroll  1 pages }
+bind Hierarchy <Home>		{ %W xview moveto 0 }
+bind Hierarchy <End>		{ %W xview moveto 1 }
+bind Hierarchy <Control-slash>	[namespace code \
+	{ SelectAll [winfo parent %W] }]
+bind Hierarchy <Control-backslash> [namespace code \
+	{ [winfo parent %W] selection clear }]
+
+bind Hierarchy <2> {
+    set tkPriv(x) %x
+    set tkPriv(y) %y
+    %W scan mark %x %y
+}
+bind Hierarchy <B2-Motion> {
+    %W scan dragto $tkPriv(x) %y
+}
+
+## BINDING HELPER PROCEDURES
+##
+## These are mostly mirrored from the Listbox class bindings.
+##
+## Some of these are hacked up to be more efficient by making calls
+## that require forknowledge of the megawidget structure.
+##
+
+# BeginSelect --
+#
+# This procedure is typically invoked on button-1 presses.  It begins
+# the process of making a selection in the hierarchy.  Its exact behavior
+# depends on the selection mode currently in effect for the hierarchy;
+# see the Motif documentation for details.
+#
+# Arguments:
+# w -		The hierarchy widget.
+# el -		The element for the selection operation (typically the
+#		one under the pointer).  Must be in numerical form.
+
+;proc BeginSelect {w el} {
+    global tkPriv
+    if {[catch {_index $w $el} el]} return
+    _selection $w clear
+    _selection $w set $el
+    set tkPriv(hierarchyPrev) $el
+}
+
+# Motion --
+#
+# This procedure is called to process mouse motion events while
+# button 1 is down.  It may move or extend the selection, depending
+# on the hierarchy's selection mode.
+#
+# Arguments:
+# w -		The hierarchy widget.
+# el -		The element under the pointer (must be a number).
+
+;proc Motion {w el} {
+    global tkPriv
+    if {[catch {_index $w $el} el] || \
+	    [string match $el $tkPriv(hierarchyPrev)]} return
+    switch [_cget $w -selectmode] {
+	browse {
+	    _selection $w clear 0 end
+	    if {![catch {_selection $w set $el}]} {
+		set tkPriv(hierarchyPrev) $el
+	    }
+	}
+	multiple {
+	    ## This happens when a double-1 occurs and all the index boxes
+	    ## have changed
+	    if {[catch {_selection $w includes \
+		    $tkPriv(hierarchyPrev)} inc]} {
+		set tkPriv(hierarchyPrev) [_index $w $el]
+		return
+	    }
+	    if {$inc} {
+		_selection $w set $el
+	    } else {
+		_selection $w clear $el
+	    }
+	    set tkPriv(hierarchyPrev) $el
+	}
+    }
+}
+
+# BeginExtend --
+#
+# This procedure is typically invoked on shift-button-1 presses.  It
+# begins the process of extending a selection in the hierarchy.  Its
+# exact behavior depends on the selection mode currently in effect
+# for the hierarchy;
+#
+# Arguments:
+# w -		The hierarchy widget.
+# el -		The element for the selection operation (typically the
+#		one under the pointer).  Must be in numerical form.
+
+;proc BeginExtend {w el} {
+    if {[catch {_index $w $el} el]} return
+    if {[string match multiple [_cget $w -selectmode]]} {
+	Motion $w $el
+    }
+}
+
+# BeginToggle --
+#
+# This procedure is typically invoked on control-button-1 presses.  It
+# begins the process of toggling a selection in the hierarchy.  Its
+# exact behavior depends on the selection mode currently in effect
+# for the hierarchy;  see the Motif documentation for details.
+#
+# Arguments:
+# w -		The hierarchy widget.
+# el -		The element for the selection operation (typically the
+#		one under the pointer).  Must be in numerical form.
+
+;proc BeginToggle {w el} {
+    global tkPriv
+    if {[catch {_index $w $el} el]} return
+    if {[string match multiple [_cget $w -selectmode]]} {
+	_selection $w anchor $el
+	if {[_selection $w includes $el]} {
+	    _selection $w clear $el
+	} else {
+	    _selection $w set $el
+	}
+	set tkPriv(hierarchyPrev) $el
+    }
+}
+
+# AutoScan --
+# This procedure is invoked when the mouse leaves an entry window
+# with button 1 down.  It scrolls the window up, down, left, or
+# right, depending on where the mouse left the window, and reschedules
+# itself as an "after" command so that the window continues to scroll until
+# the mouse moves back into the window or the mouse button is released.
+#
+# Arguments:
+# w -		The hierarchy widget.
+
+;proc AutoScan {w} {
+    global tkPriv
+    if {![winfo exists $w]} return
+    set x $tkPriv(x)
+    set y $tkPriv(y)
+    if {$y>=[winfo height $w]} {
+	$w yview scroll 1 units
+    } elseif {$y<0} {
+	$w yview scroll -1 units
+    } elseif {$x>=[winfo width $w]} {
+	$w xview scroll 2 units
+    } elseif {$x<0} {
+	$w xview scroll -2 units
+    } else {
+	return
+    }
+    #Motion $w [$w index @$x,$y]
+    set tkPriv(afterId) [after 50 [namespace current]::AutoScan $w]
+}
+
+# SelectAll
+#
+# This procedure is invoked to handle the "select all" operation.
+# For single and browse mode, it just selects the root element.
+# Otherwise it selects everything in the widget.
+#
+# Arguments:
+# w -		The hierarchy widget.
+
+;proc SelectAll w {
+    if {[regexp (browse|single) [_cget $w -selectmode]]} {
+	_selection $w clear
+	_selection $w set root
+    } else {
+	_selection $w set all
+    }
+}
+
+#------------------------------------------------------------
+# Default nodelook methods
+#------------------------------------------------------------
+
+;proc FileLook { w np isopen } {
+    upvar \#0 [namespace current]::$w data
+    set path [eval file join $np]
+    set file [lindex $np end]
+    set bmp  {}
+    if {[file readable $path]} {
+	if {[file isdirectory $path]} {
+	    if {$isopen} {
+		## We know that kids will always be set by the time
+		## the isopen is set to 1
+		if {[string compare $data(:$np,kids) {}]} {
+		    set bmp ::Widget::Hierarchy::bmp:dir_minus
+		} else {
+		    set bmp ::Widget::Hierarchy::bmp:dir
+		}
+	    } else {
+		set bmp ::Widget::Hierarchy::bmp:dir_plus
+	    }
+	    if 0 {
+		## NOTE: accurate, but very expensive
+		if {[string compare [FileList $w $np] {}]} {
+		    set bmp [expr {$isopen ?\
+			    {::Widget::Hierarchy::bmp:dir_minus} :\
+			    {::Widget::Hierarchy::bmp:dir_plus}}]
+		} else {
+		    set bmp ::Widget::Hierarchy::bmp:dir
+		}
+	    }
+	}
+	set fg \#000000
+    } elseif {[string compare $data(-showparent) {}] && \
+	    [string match $data(-showparent) $file]} {
+	set fg \#0000FF
+	set bmp ::Widget::Hierarchy::bmp:up
+    } else {
+	set fg \#a9a9a9
+	if {[file isdirectory $path]} {set bmp ::Widget::Hierarchy::bmp:dir}
+    }
+    return [list $file $data(-font) $bmp $fg] 
+}
+
+## FileList
+# ARGS:	w	hierarchy widget
+#	np	node path	
+# Returns:	directory listing
+##
+;proc FileList { w np } {
+    set pwd [pwd]
+    if {[catch "cd \[file join $np\]"]} {
+	set list {}
+    } else {
+	global tcl_platform
+	upvar \#0 [namespace current]::$w data
+	set str *
+	if {!$data(-showfiles)} { append str / }
+	if {$data(-showall) && [string match unix $tcl_platform(platform)]} {
+	    ## NOTE: Use of non-core lremove
+	    if {[catch {lsort [concat [glob -nocomplain $str] \
+		    [lremove [glob -nocomplain .$str] {. ..}]]} list]} {
+		return {}
+	    }
+	} else {
+	    ## The extra catch is necessary for unusual error conditions
+	    if {[catch {lsort [glob -nocomplain $str]} list]} {
+		return {}
+	    }
+	}
+	set root $data(-root)
+	if {[string compare {} $data(-showparent)] && \
+		[string match $root $np]} {
+	    if {![regexp {^(.:)?/+$} $root] && \
+		    [string compare [file dir $root] $root]} {
+		set list [linsert $list 0 $data(-showparent)]
+	    }
+	}
+    }
+    cd $pwd
+    return $list
+}
+
+;proc FileActivate { w np isopen } {
+    upvar \#0 [namespace current]::$w data
+    set path [eval file join $np]
+    if {[file isdirectory $path]} return
+    if {[string compare $data(-showparent) {}] && \
+	    [string match $data(-showparent) [lindex $np end]]} {
+	$w configure -root [file dir $data(-root)]
+    }
+}
+
+;proc WidgetLook { W np isopen } {
+    upvar \#0 [namespace current]::$W data
+    if {$data(-showall)} {
+	set w [lindex $np end]
+    } else {
+	set w [join $np {}]
+	regsub {\.\.} $w {.} w
+    }
+    if {[string compare [winfo children $w] {}]} {set fg blue} {set fg black}
+    return [list "\[[winfo class $w]\] [lindex $np end]" {} {} $fg]
+}
+
+;proc WidgetList { W np } {
+    upvar \#0 [namespace current]::$W data
+    if {$data(-showall)} {
+	set w [lindex $np end]
+    } else {
+	set w [join $np {}]
+	regsub {\.\.} $w {.} w
+    }
+    set kids {}
+    foreach i [lsort [winfo children $w]] {
+	if {$data(-showall)} {
+	    lappend kids $i
+	} else {
+	    lappend kids [file extension $i]
+	}
+    }
+    return $kids
+}
+
+;proc WidgetActivate { w np isopen } {}
+
+
+## BITMAPS
+##
+image create bitmap ::Widget::Hierarchy::bmp:dir -data {#define folder_width 16
+#define folder_height 12
+static char folder_bits[] = {
+  0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40,
+  0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
+image create bitmap ::Widget::Hierarchy::bmp:dir_plus -data {#define folder_plus_width 16
+  #define folder_plus_height 12
+static char folder_plus_bits[] = {
+  0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x82, 0x40,
+  0x82, 0x40, 0xe2, 0x43, 0x82, 0x40, 0x82, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
+image create bitmap ::Widget::Hierarchy::bmp:dir_minus -data {#define folder_minus_width 16
+#define folder_minus_height 12
+static char folder_minus_bits[] = {
+  0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40,
+  0x02, 0x40, 0xe2, 0x43, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
+image create bitmap ::Widget::Hierarchy::bmp:up -data {#define up.xbm_width 16
+#define up.xbm_height 12
+static unsigned char up.xbm_bits[] = {
+  0x00, 0x00, 0x10, 0x00, 0x38, 0x00, 0x7c, 0x00, 0xfe, 0x00, 0x38, 0x00,
+  0x38, 0x00, 0x38, 0x00, 0xf8, 0x7f, 0xf0, 0x7f, 0xe0, 0x7f, 0x00, 0x00};}
+image create bitmap ::Widget::Hierarchy::bmp:text -data {#define text_width 15
+#define text_height 14
+static char text_bits[] = {
+  0xff,0x07,0x01,0x0c,0x01,0x04,0x01,0x24,0xf9,0x7d,0x01,0x78,0x01,0x40,0xf1,
+  0x41,0x01,0x40,0x01,0x40,0xf1,0x41,0x01,0x40,0x01,0x40,0xff,0x7f};}
+
+}; # end namespace ::Widget::Hierarchy
+
+return