tree.tcl

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

proc Tree::_init_drag_cmd { path X Y top } {
    set path [winfo parent $path]
    set ltags [$path.c gettags current]
    set item  [lindex $ltags 1]
    if { [string equal $item "node"] ||
         [string equal $item "img"]  ||
         [string equal $item "win"] } {
        set node [Tree::_get_node_name $path current 2]
        if { [set cmd [Widget::getoption $path -draginitcmd]] != "" } {
            return [uplevel \#0 $cmd [list $path $node $top]]
        }
        if { [set type [Widget::getoption $path -dragtype]] == "" } {
            set type "TREE_NODE"
        }
        if { [set img [Widget::getoption $path.$node -image]] != "" } {
            pack [label $top.l -image $img -padx 0 -pady 0]
        }
        return [list $type {copy move link} $node]
    }
    return {}
}


# ----------------------------------------------------------------------------
#  Command Tree::_drop_cmd
# ----------------------------------------------------------------------------
proc Tree::_drop_cmd { path source X Y op type dnddata } {
    set path [winfo parent $path]
    variable $path
    upvar 0  $path data

    $path.c delete drop
    if { [string length $data(dnd,afterid)] } {
        after cancel $data(dnd,afterid)
        set data(dnd,afterid) ""
    }
    set data(dnd,scroll) ""
    if { [llength $data(dnd,node)] } {
        if { [set cmd [Widget::getoption $path -dropcmd]] != "" } {
            return [uplevel \#0 $cmd [list $path $source $data(dnd,node) $op $type $dnddata]]
        }
    }
    return 0
}


# ----------------------------------------------------------------------------
#  Command Tree::_over_cmd
# ----------------------------------------------------------------------------
proc Tree::_over_cmd { path source event X Y op type dnddata } {
    set path [winfo parent $path]
    variable $path
    upvar 0  $path data

    if { [string equal $event "leave"] } {
        # we leave the window tree
        $path.c delete drop
        if { [string length $data(dnd,afterid)] } {
            after cancel $data(dnd,afterid)
            set data(dnd,afterid) ""
        }
        set data(dnd,scroll) ""
        return 0
    }

    if { [string equal $event "enter"] } {
        # we enter the window tree - dnd data initialization
        set mode [Widget::getoption $path -dropovermode]
        set data(dnd,mode) 0
        foreach c {w p n} {
            set data(dnd,mode) [expr {($data(dnd,mode) << 1) | ([string first $c $mode] != -1)}]
        }
        set bbox [$path.c bbox all]
        if { [llength $bbox] } {
            set data(dnd,xs) [lindex $bbox 2]
            set data(dnd,empty) 0
        } else {
            set data(dnd,xs) 0
            set data(dnd,empty) 1
        }
        set data(dnd,node) {}
    }

    set x [expr {$X-[winfo rootx $path]}]
    set y [expr {$Y-[winfo rooty $path]}]
    $path.c delete drop
    set data(dnd,node) {}

    # test for auto-scroll unless mode is widget only
    if { $data(dnd,mode) != 4 && [_auto_scroll $path $x $y] != "" } {
        return 2
    }

    if { $data(dnd,mode) & 4 } {
        # dropovermode includes widget
        set target [list widget]
        set vmode  4
    } else {
        set target [list ""]
        set vmode  0
    }
    if { ($data(dnd,mode) & 2) && $data(dnd,empty) } {
        # dropovermode includes position and tree is empty
        lappend target [list root 0]
        set vmode  [expr {$vmode | 2}]
    }

    set xc [$path.c canvasx $x]
    set xs $data(dnd,xs)
    if { $xc <= $xs } {
        set yc   [$path.c canvasy $y]
        set dy   [$path.c cget -yscrollincrement]
        set line [expr {int($yc/$dy)}]
        set xi   0
        set yi   [expr {$line*$dy}]
        set ys   [expr {$yi+$dy}]
        set found 0
        foreach id [$path.c find overlapping $xi $yi $xs $ys] {
            set ltags [$path.c gettags $id]
            set item  [lindex $ltags 1]
            if { [string equal $item "node"] ||
                 [string equal $item "img"]  ||
                 [string equal $item "win"] } {
                # item is the label or image/window of the node
                set node [Tree::_get_node_name $path $id 2]
		set found 1
		break
	    }
	}
	if {$found} {
	    set padx   [_get_node_padx $path $node]
	    set deltax [_get_node_deltax $path $node]
            set xi [expr {[lindex [$path.c coords n:$node] 0] - $padx - 1}]
                if { $data(dnd,mode) & 1 } {
                    # dropovermode includes node
                    lappend target $node
                    set vmode [expr {$vmode | 1}]
                } else {
                    lappend target ""
                }

                if { $data(dnd,mode) & 2 } {
                    # dropovermode includes position
                    if { $yc >= $yi+$dy/2 } {
                        # position is after $node
                        if { [Widget::getoption $path.$node -open] &&
                             [llength $data($node)] > 1 } {
                            # $node is open and have subnodes
                            # drop position is 0 in children of $node
                            set parent $node
                            set index  0
                            set xli    [expr {$xi-5}]
                        } else {
                            # $node is not open and doesn't have subnodes
                            # drop position is after $node in children of parent of $node
                            set parent [lindex $data($node) 0]
                            set index  [lsearch -exact $data($parent) $node]
                            set xli    [expr {$xi - $deltax - 5}]
                        }
                        set yl $ys
                    } else {
                        # position is before $node
                        # drop position is before $node in children of parent of $node
                        set parent [lindex $data($node) 0]
                        set index  [expr {[lsearch -exact $data($parent) $node] - 1}]
                        set xli    [expr {$xi - $deltax - 5}]
                        set yl     $yi
                    }
                    lappend target [list $parent $index]
                    set vmode  [expr {$vmode | 2}]
                } else {
                    lappend target {}
                }

                if { ($vmode & 3) == 3 } {
                    # result have both node and position
                    # we compute what is the preferred method
                    if { $yc-$yi <= 3 || $ys-$yc <= 3 } {
                        lappend target "position"
                    } else {
                        lappend target "node"
                    }
                }
            }
        }

    if { $vmode && [set cmd [Widget::getoption $path -dropovercmd]] != "" } {
        # user-defined dropover command
        set res     [uplevel \#0 $cmd [list $path $source $target $op $type $dnddata]]
        set code    [lindex $res 0]
        set newmode 0
        if { $code & 1 } {
            # update vmode
            set mode [lindex $res 1]
            if { ($vmode & 1) && [string equal $mode "node"] } {
                set newmode 1
            } elseif { ($vmode & 2) && [string equal $mode "position"] } {
                set newmode 2
            } elseif { ($vmode & 4) && [string equal $mode "widget"] } {
                set newmode 4
            }
        }
        set vmode $newmode
    } else {
        if { ($vmode & 3) == 3 } {
            # result have both item and position
            # we choose the preferred method
            if { [string equal [lindex $target 3] "position"] } {
                set vmode [expr {$vmode & ~1}]
            } else {
                set vmode [expr {$vmode & ~2}]
            }
        }

        if { $data(dnd,mode) == 4 || $data(dnd,mode) == 0 } {
            # dropovermode is widget or empty - recall is not necessary
            set code 1
        } else {
            set code 3
        }
    }

    if {!$data(dnd,empty)} {
	# draw dnd visual following vmode
	if { $vmode & 1 } {
	    set data(dnd,node) [list "node" [lindex $target 1]]
	    $path.c create rectangle $xi $yi $xs $ys -tags drop
	} elseif { $vmode & 2 } {
	    set data(dnd,node) [concat "position" [lindex $target 2]]
	    $path.c create line $xli [expr {$yl-$dy/2}] $xli $yl $xs $yl -tags drop
	} elseif { $vmode & 4 } {
	    set data(dnd,node) [list "widget"]
	} else {
	    set code [expr {$code & 2}]
	}
    }

    if { $code & 1 } {
        DropSite::setcursor based_arrow_down
    } else {
        DropSite::setcursor dot
    }
    return $code
}


# ----------------------------------------------------------------------------
#  Command Tree::_auto_scroll
# ----------------------------------------------------------------------------
proc Tree::_auto_scroll { path x y } {
    variable $path
    upvar 0  $path data

    set xmax   [winfo width  $path]
    set ymax   [winfo height $path]
    set scroll {}
    if { $y <= 6 } {
        if { [lindex [$path.c yview] 0] > 0 } {
            set scroll [list yview -1]
            DropSite::setcursor sb_up_arrow
        }
    } elseif { $y >= $ymax-6 } {
        if { [lindex [$path.c yview] 1] < 1 } {
            set scroll [list yview 1]
            DropSite::setcursor sb_down_arrow
        }
    } elseif { $x <= 6 } {
        if { [lindex [$path.c xview] 0] > 0 } {
            set scroll [list xview -1]
            DropSite::setcursor sb_left_arrow
        }
    } elseif { $x >= $xmax-6 } {
        if { [lindex [$path.c xview] 1] < 1 } {
            set scroll [list xview 1]
            DropSite::setcursor sb_right_arrow
        }
    }

    if { [string length $data(dnd,afterid)] && ![string equal $data(dnd,scroll) $scroll] } {
        after cancel $data(dnd,afterid)
        set data(dnd,afterid) ""
    }

    set data(dnd,scroll) $scroll
    if { [string length $scroll] && ![string length $data(dnd,afterid)] } {
        set data(dnd,afterid) [after 200 Tree::_scroll $path $scroll]
    }
    return $data(dnd,afterid)
}


# ----------------------------------------------------------------------------
#  Command Tree::_scroll
# ----------------------------------------------------------------------------
proc Tree::_scroll { path cmd dir } {
    variable $path
    upvar 0  $path data

    if { ($dir == -1 && [lindex [$path.c $cmd] 0] > 0) ||
         ($dir == 1  && [lindex [$path.c $cmd] 1] < 1) } {
        $path.c $cmd scroll $dir units
        set data(dnd,afterid) [after 100 Tree::_scroll $path $cmd $dir]
    } else {
        set data(dnd,afterid) ""
        DropSite::setcursor dot
    }
}

# Tree::_keynav --
#
#	Handle navigational keypresses on the tree.
#
# Arguments:
#	which      tag indicating the direction of motion:
#                  up         move to the node graphically above current
#                  down       move to the node graphically below current
#                  left       close current if open, else move to parent
#                  right      open current if closed, else move to child
#                  open       open current if closed, close current if open
#       win        name of the tree widget
#
# Results:
#	None.

proc Tree::_keynav {which win} {
    # Keyboard navigation is riddled with special cases.  In order to avoid
    # the complex logic, we will instead make a list of all the visible,
    # selectable nodes, then do a simple next or previous operation.

    # One easy way to get all of the visible nodes is to query the canvas
    # object for all the items with the "node" tag; since the tree is always
    # completely redrawn, this list will be in vertical order.
    set nodes {}
    foreach nodeItem [$win.c find withtag node] {
	set node [Tree::_get_node_name $win $nodeItem 2]
	if { [Widget::cget $win.$node -selectable] } {
	    lappend nodes $node
	}
    }

    # Keyboard navigation is all relative to the current node
    # surles: Get the current node for single or multiple selection schemas.
    set node [_get_current_node $win]

    switch -exact -- $which {
	"up" {
	    # Up goes to the node that is vertically above the current node
	    # (NOT necessarily the current node's parent)
	    if { [string equal $node ""] } {
		return
	    }
	    set index [lsearch -exact $nodes $node]
	    incr index -1
	    if { $index >= 0 } {
		$win selection set [lindex $nodes $index]
		_set_current_node $win [lindex $nodes $index]
		$win see [lindex $nodes $index]
		return
	    }
	}
	"down" {
	    # Down goes to the node that is vertically below the current node
	    if { [string equal $node ""] } {
		$win selection set [lindex $nodes 0]
		_set_current_node $win [lindex $nodes 0]
		$win see [lindex $nodes 0]
		return
	    }

	    set index [lsearch -exact $nodes $node]
	    incr index
	    if { $index < [llength $nodes] } {
		$win selection set [lindex $nodes $index]
		_set_current_node $win [lindex $nodes $index]
		$win see [lindex $nodes $index]
		return
	    }
	}
	"right" {
	    # On a right arrow, if the current node is closed, open it.
	    # If the current node is open, go to