tree.tcl

The BWidget Toolkit is a high-level Widget Set for Tcl/Tk built using native Tcl/Tk 8.x namespaces.

        if { [Widget::hasChanged $path.$node -open val] } {
            if {[llength $data($node)] > 1} {
                # node have subnodes - full redraw
                _redraw_idle $path 3
            } else {
                # force a redraw of the plus/minus sign
                set flag [expr {$flag | 8}]
            }
        }

	if {$data(upd,level) < 3 && [Widget::hasChanged $path.$node -padx x]} {
	    _redraw_idle $path 3
	}

	if { $data(upd,level) < 3 && $flag } {
            if { [set idx [lsearch -exact $data(upd,nodes) $node]] == -1 } {
                lappend data(upd,nodes) $node $flag
            } else {
                incr idx
                set flag [expr {[lindex $data(upd,nodes) $idx] | $flag}]
                set data(upd,nodes) [lreplace $data(upd,nodes) $idx $idx $flag]
            }
            _redraw_idle $path 2
        }
    }
    return $result
}


# ----------------------------------------------------------------------------
#  Command Tree::itemcget
# ----------------------------------------------------------------------------
proc Tree::itemcget { path node option } {
    # Instead of upvar'ing $path as data for this test, just directly refer to
    # it, as that is faster.
    set node [_node_name $path $node]
    if { [string equal $node "root"] || \
	    ![info exists ::Tree::${path}($node)] } {
        return -code error "node \"$node\" does not exist"
    }

    return [Widget::cget $path.$node $option]
}


# ----------------------------------------------------------------------------
#  Command Tree::bindText
# ----------------------------------------------------------------------------
proc Tree::bindText { path event script } {
    if {[string length $script]} {
	append script " \[Tree::_get_node_name [list $path] current 2\]"
    }
    $path.c bind "node" $event $script
    if {[Widget::getoption $path -selectfill]} {
	$path.c bind "box" $event $script
    } else {
	$path.c bind "box" $event {}
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::bindImage
# ----------------------------------------------------------------------------
proc Tree::bindImage { path event script } {
    if {[string length $script]} {
	append script " \[Tree::_get_node_name [list $path] current 2\]"
    }
    $path.c bind "img" $event $script
    if {[Widget::getoption $path -selectfill]} {
	$path.c bind "box" $event $script
    } else {
	$path.c bind "box" $event {}
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::delete
# ----------------------------------------------------------------------------
proc Tree::delete { path args } {
    variable $path
    upvar 0  $path data

    foreach lnodes $args {
	foreach node $lnodes {
            set node [_node_name $path $node]
	    if { ![string equal $node "root"] && [info exists data($node)] } {
		set parent [lindex $data($node) 0]
		set idx	   [lsearch -exact $data($parent) $node]
		set data($parent) [lreplace $data($parent) $idx $idx]
		_subdelete $path [list $node]
	    }
	}
    }

    _redraw_idle $path 3
}


# ----------------------------------------------------------------------------
#  Command Tree::move
# ----------------------------------------------------------------------------
proc Tree::move { path parent node index } {
    variable $path
    upvar 0  $path data

    set node [_node_name $path $node]
    if { [string equal $node "root"] || ![info exists data($node)] } {
        return -code error "node \"$node\" does not exist"
    }
    if { ![info exists data($parent)] } {
        return -code error "node \"$parent\" does not exist"
    }
    set p $parent
    while { ![string equal $p "root"] } {
        if { [string equal $p $node] } {
            return -code error "node \"$parent\" is a descendant of \"$node\""
        }
        set p [parent $path $p]
    }

    set oldp        [lindex $data($node) 0]
    set idx         [lsearch -exact $data($oldp) $node]
    set data($oldp) [lreplace $data($oldp) $idx $idx]
    set data($node) [concat [list $parent] [lrange $data($node) 1 end]]
    if { [string equal $index "end"] } {
        lappend data($parent) $node
    } else {
        incr index
        set data($parent) [linsert $data($parent) $index $node]
    }
    if { ([string equal $oldp "root"] ||
          ([visible $path $oldp] && [Widget::getoption $path.$oldp   -open])) ||
         ([string equal $parent "root"] ||
          ([visible $path $parent] && [Widget::getoption $path.$parent -open])) } {
        _redraw_idle $path 3
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::reorder
# ----------------------------------------------------------------------------
proc Tree::reorder { path node neworder } {
    variable $path
    upvar 0  $path data

    set node [_node_name $path $node]
    if { ![info exists data($node)] } {
        return -code error "node \"$node\" does not exist"
    }
    set children [lrange $data($node) 1 end]
    if { [llength $children] } {
        set children [BWidget::lreorder $children $neworder]
        set data($node) [linsert $children 0 [lindex $data($node) 0]]
        if { [visible $path $node] && [Widget::getoption $path.$node -open] } {
            _redraw_idle $path 3
        }
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::selection
# ----------------------------------------------------------------------------
proc Tree::selection { path cmd args } {
    variable $path
    upvar 0  $path data

    switch -- $cmd {
	toggle {
            foreach node $args {
                set node [_node_name $path $node]
                if {![info exists data($node)]} {
		    return -code error \
			    "$path selection toggle: Cannot toggle unknown node \"$node\"."
		}
	    }
            foreach node $args {
                set node [_node_name $path $node]
		if {[$path selection includes $node]} {
		    $path selection remove $node
		} else {
		    $path selection add $node
		}
            }
	}
        set {
            foreach node $args {
                set node [_node_name $path $node]
                if {![info exists data($node)]} {
		    return -code error \
			    "$path selection set: Cannot select unknown node \"$node\"."
		}
	    }
            set data(selnodes) {}
            foreach node $args {
                set node [_node_name $path $node]
		if { [Widget::getoption $path.$node -selectable] } {
		    if { [lsearch -exact $data(selnodes) $node] == -1 } {
			lappend data(selnodes) $node
		    }
		}
            }
	    __call_selectcmd $path
        }
        add {
            foreach node $args {
                set node [_node_name $path $node]
                if {![info exists data($node)]} {
		    return -code error \
			    "$path selection add: Cannot select unknown node \"$node\"."
		}
	    }
            foreach node $args {
                set node [_node_name $path $node]
		if { [Widget::getoption $path.$node -selectable] } {
		    if { [lsearch -exact $data(selnodes) $node] == -1 } {
			lappend data(selnodes) $node
		    }
		}
            }
	    __call_selectcmd $path
        }
	range {
	    # Here's our algorithm:
	    #    make a list of all nodes, then take the range from node1
	    #    to node2 and select those nodes
	    #
	    # This works because of how this widget handles redraws:
	    #    The tree is always completely redrawn, and always from
	    #    top to bottom. So the list of visible nodes *is* the
	    #    list of nodes, and we can use that to decide which nodes
	    #    to select.

	    if {[llength $args] != 2} {
		return -code error \
			"wrong#args: Expected $path selection range node1 node2"
	    }

	    foreach {node1 node2} $args break

            set node1 [_node_name $path $node1]
            set node2 [_node_name $path $node2]
	    if {![info exists data($node1)]} {
		return -code error \
			"$path selection range: Cannot start range at unknown node \"$node1\"."
	    }
	    if {![info exists data($node2)]} {
		return -code error \
			"$path selection range: Cannot end range at unknown node \"$node2\"."
	    }

	    set nodes {}
	    foreach nodeItem [$path.c find withtag node] {
		set node [Tree::_get_node_name $path $nodeItem 2]
		if { [Widget::getoption $path.$node -selectable] } {
		    lappend nodes $node
		}
	    }
	    # surles: Set the root string to the first element on the list.
	    if {$node1 == "root"} {
		set node1 [lindex $nodes 0]
	    }
	    if {$node2 == "root"} {
		set node2 [lindex $nodes 0]
	    }

	    # Find the first visible ancestor of node1, starting with node1
	    while {[set index1 [lsearch -exact $nodes $node1]] == -1} {
		set node1 [lindex $data($node1) 0]
	    }
	    # Find the first visible ancestor of node2, starting with node2
	    while {[set index2 [lsearch -exact $nodes $node2]] == -1} {
		set node2 [lindex $data($node2) 0]
	    }
	    # If the nodes were given in backwards order, flip the
	    # indices now
	    if { $index2 < $index1 } {
		incr index1 $index2
		set index2 [expr {$index1 - $index2}]
		set index1 [expr {$index1 - $index2}]
	    }
	    set data(selnodes) [lrange $nodes $index1 $index2]
	    __call_selectcmd $path
	}
        remove {
            foreach node $args {
                set node [_node_name $path $node]
                if { [set idx [lsearch -exact $data(selnodes) $node]] != -1 } {
                    set data(selnodes) [lreplace $data(selnodes) $idx $idx]
                }
            }
	    __call_selectcmd $path
        }
        clear {
	    if {[llength $args] != 0} {
		return -code error \
			"wrong#args: Expected $path selection clear"
	    }
            set data(selnodes) {}
	    __call_selectcmd $path
        }
        get {
	    if {[llength $args] != 0} {
		return -code error \
			"wrong#args: Expected $path selection get"
	    }
            return $data(selnodes)
        }
        includes {
	    if {[llength $args] != 1} {
		return -code error \
			"wrong#args: Expected $path selection includes node"
	    }
	    set node [lindex $args 0]
            set node [_node_name $path $node]
            return [expr {[lsearch -exact $data(selnodes) $node] != -1}]
        }
        default {
            return
        }
    }
    _redraw_idle $path 1
}


proc Tree::getcanvas { path } {
    return $path.c
}


proc Tree::__call_selectcmd { path } {
    variable $path
    upvar 0  $path data

    set selectcmd [Widget::getoption $path -selectcommand]
    if {[llength $selectcmd]} {
	lappend selectcmd $path
	lappend selectcmd $data(selnodes)
	uplevel \#0 $selectcmd
    }
    return
}

# ----------------------------------------------------------------------------
#  Command Tree::exists
# ----------------------------------------------------------------------------
proc Tree::exists { path node } {
    variable $path
    upvar 0  $path data

    set node [_node_name $path $node]
    return [info exists data($node)]
}


# ----------------------------------------------------------------------------
#  Command Tree::visible
# ----------------------------------------------------------------------------
proc Tree::visible { path node } {
    set node [_node_name $path $node]
    set idn [$path.c find withtag n:$node]
    return [llength $idn]
}


# ----------------------------------------------------------------------------
#  Command Tree::parent
# ----------------------------------------------------------------------------
proc Tree::parent { path node } {
    variable $path
    upvar 0  $path data

    set node [_node_name $path $node]
    if { ![info exists data($node)] } {
        return -code error "node \"$node\" does not exist"
    }
    return [lindex $data($node) 0]
}


# ----------------------------------------------------------------------------