0byt3m1n1
Path:
C:
/
Program Files
/
R
/
R-4.4.1
/
Tcl
/
lib
/
BWidget
/
[
Home
]
File: tree.tcl
# ---------------------------------------------------------------------------- # tree.tcl # This file is part of Unifix BWidget Toolkit # $Id: tree.tcl,v 1.60.2.4 2011/06/23 08:28:04 oehhar Exp $ # ---------------------------------------------------------------------------- # Index of commands: # - Tree::create # - Tree::configure # - Tree::cget # - Tree::insert # - Tree::itemconfigure # - Tree::itemcget # - Tree::bindArea # - Tree::bindText # - Tree::bindImage # - Tree::delete # - Tree::move # - Tree::reorder # - Tree::selection # - Tree::exists # - Tree::parent # - Tree::index # - Tree::nodes # - Tree::see # - Tree::opentree # - Tree::closetree # - Tree::edit # - Tree::xview # - Tree::yview # - Tree::_update_edit_size # - Tree::_destroy # - Tree::_see # - Tree::_recexpand # - Tree::_subdelete # - Tree::_update_scrollregion # - Tree::_cross_event # - Tree::_draw_node # - Tree::_draw_subnodes # - Tree::_update_nodes # - Tree::_draw_tree # - Tree::_redraw_tree # - Tree::_redraw_selection # - Tree::_redraw_idle # - Tree::_drag_cmd # - Tree::_drop_cmd # - Tree::_over_cmd # - Tree::_auto_scroll # - Tree::_scroll # ---------------------------------------------------------------------------- namespace eval Tree { Widget::define Tree tree DragSite DropSite DynamicHelp namespace eval Node { Widget::declare Tree::Node { {-text String "" 0} {-font TkResource "" 0 listbox} {-image TkResource "" 0 label} {-window String "" 0} {-fill TkResource black 0 {listbox -foreground}} {-data String "" 0} {-open Boolean 0 0} {-selectable Boolean 1 0} {-drawcross Enum auto 0 {auto always never allways}} {-padx Int -1 0 "%d >= -1"} {-deltax Int -1 0 "%d >= -1"} {-anchor String "w" 0 ""} } } DynamicHelp::include Tree::Node balloon Widget::tkinclude Tree canvas .c \ remove { -insertwidth -insertbackground -insertborderwidth -insertofftime -insertontime -selectborderwidth -closeenough -confine -scrollregion -xscrollincrement -yscrollincrement -width -height } \ initialize { -relief sunken -borderwidth 2 -takefocus 1 -highlightthickness 1 -width 200 } Widget::declare Tree { {-deltax Int 10 0 "%d >= 0"} {-deltay Int 15 0 "%d >= 0"} {-padx Int 20 0 "%d >= 0"} {-background TkResource "" 0 listbox} {-selectbackground TkResource "" 0 listbox} {-selectforeground TkResource "" 0 listbox} {-selectcommand String "" 0} {-width TkResource "" 0 listbox} {-height TkResource "" 0 listbox} {-selectfill Boolean 0 0} {-showlines Boolean 1 0} {-linesfill TkResource "" 0 {listbox -foreground}} {-linestipple TkResource "" 0 {label -bitmap}} {-crossfill TkResource "" 0 {listbox -foreground}} {-redraw Boolean 1 0} {-opencmd String "" 0} {-closecmd String "" 0} {-dropovermode Flag "wpn" 0 "wpn"} {-bg Synonym -background} {-crossopenimage String "" 0} {-crosscloseimage String "" 0} {-crossopenbitmap String "" 0} {-crossclosebitmap String "" 0} } DragSite::include Tree "TREE_NODE" 1 DropSite::include Tree { TREE_NODE {copy {} move {}} } Widget::addmap Tree "" .c {-deltay -yscrollincrement} # Trees on windows have a white (system window) background if { $::tcl_platform(platform) == "windows" } { option add *Tree.c.background SystemWindow widgetDefault option add *TreeNode.fill SystemWindowText widgetDefault } bind Tree <FocusIn> [list after idle {BWidget::refocus %W %W.c}] bind Tree <Destroy> [list Tree::_destroy %W] bind Tree <Configure> [list Tree::_update_scrollregion %W] bind TreeSentinalStart <Button-1> { if { $::Tree::sentinal(%W) } { set ::Tree::sentinal(%W) 0 break } } bind TreeSentinalEnd <Button-1> { set ::Tree::sentinal(%W) 0 } bind TreeFocus <Button-1> [list focus %W] variable _edit } # ---------------------------------------------------------------------------- # Command Tree::create # ---------------------------------------------------------------------------- proc Tree::create { path args } { variable $path upvar 0 $path data Widget::init Tree $path $args set ::Tree::sentinal($path.c) 0 if {[Widget::cget $path -crossopenbitmap] == ""} { set file [file join $::BWIDGET::LIBRARY images "minus.xbm"] Widget::configure $path [list -crossopenbitmap @$file] } if {[Widget::cget $path -crossclosebitmap] == ""} { set file [file join $::BWIDGET::LIBRARY images "plus.xbm"] Widget::configure $path [list -crossclosebitmap @$file] } set data(root) {{}} set data(selnodes) {} set data(upd,level) 0 set data(upd,nodes) {} set data(upd,afterid) "" set data(dnd,scroll) "" set data(dnd,afterid) "" set data(dnd,selnodes) {} set data(dnd,node) "" frame $path -class Tree -bd 0 -highlightthickness 0 -relief flat \ -takefocus 0 # For 8.4+ we don't want to inherit the padding catch {$path configure -padx 0 -pady 0} eval [list canvas $path.c] [Widget::subcget $path .c] -xscrollincrement 8 bindtags $path.c [list TreeSentinalStart TreeFocus $path.c Canvas \ [winfo toplevel $path] all TreeSentinalEnd] pack $path.c -expand yes -fill both $path.c bind cross <ButtonPress-1> [list Tree::_cross_event $path] # Added by ericm@scriptics.com # These allow keyboard traversal of the tree bind $path.c <KeyPress-Up> [list Tree::_keynav up $path] bind $path.c <KeyPress-Down> [list Tree::_keynav down $path] bind $path.c <KeyPress-Right> [list Tree::_keynav right $path] bind $path.c <KeyPress-Left> [list Tree::_keynav left $path] bind $path.c <KeyPress-space> [list +Tree::_keynav space $path] # These allow keyboard control of the scrolling bind $path.c <Control-KeyPress-Up> [list $path.c yview scroll -1 units] bind $path.c <Control-KeyPress-Down> [list $path.c yview scroll 1 units] bind $path.c <Control-KeyPress-Left> [list $path.c xview scroll -1 units] bind $path.c <Control-KeyPress-Right> [list $path.c xview scroll 1 units] # ericm@scriptics.com BWidget::bindMouseWheel $path.c DragSite::setdrag $path $path.c Tree::_init_drag_cmd \ [Widget::cget $path -dragendcmd] 1 DropSite::setdrop $path $path.c Tree::_over_cmd Tree::_drop_cmd 1 Widget::create Tree $path set w [Widget::cget $path -width] set h [Widget::cget $path -height] set dy [Widget::cget $path -deltay] $path.c configure -width [expr {$w*8}] -height [expr {$h*$dy}] # ericm # Bind <Button-1> to select the clicked node -- no reason not to, right? ## Bind button 1 to select the node via the _mouse_select command. ## This command will generate the proper <<TreeSelect>> virtual event ## when necessary. set selectcmd Tree::_mouse_select Tree::bindText $path <Button-1> [list $selectcmd $path set] Tree::bindImage $path <Button-1> [list $selectcmd $path set] Tree::bindText $path <Control-Button-1> [list $selectcmd $path toggle] Tree::bindImage $path <Control-Button-1> [list $selectcmd $path toggle] # Add sentinal bindings for double-clicking on items, to handle the # gnarly Tk bug wherein: # ButtonClick # ButtonClick # On a canvas item translates into button click on the item, button click # on the canvas, double-button on the item, single button click on the # canvas (which can happen if the double-button on the item causes some # other event to be handled in between when the button clicks are examined # for the canvas) $path.c bind TreeItemSentinal <Double-Button-1> \ [list set ::Tree::sentinal($path.c) 1] # ericm return $path } # ---------------------------------------------------------------------------- # Command Tree::configure # ---------------------------------------------------------------------------- proc Tree::configure { path args } { variable $path upvar 0 $path data set res [Widget::configure $path $args] set ch1 [expr {[Widget::hasChanged $path -deltax val] | [Widget::hasChanged $path -deltay dy] | [Widget::hasChanged $path -padx val] | [Widget::hasChanged $path -showlines val]}] set ch2 [expr {[Widget::hasChanged $path -selectbackground val] | [Widget::hasChanged $path -selectforeground val]}] if { [Widget::hasChanged $path -linesfill fill] | [Widget::hasChanged $path -linestipple stipple] } { $path.c itemconfigure line -fill $fill -stipple $stipple } if { [Widget::hasChanged $path -crossfill fill] } { $path.c itemconfigure cross -foreground $fill } if {[Widget::hasChanged $path -selectfill fill]} { # Make sure that the full-width boxes have either all or none # of the standard node bindings if {$fill} { foreach event [$path.c bind "node"] { $path.c bind "box" $event [$path.c bind "node" $event] } } else { foreach event [$path.c bind "node"] { $path.c bind "box" $event {} } } } if { $ch1 } { _redraw_idle $path 3 } elseif { $ch2 } { _redraw_idle $path 1 } if { [Widget::hasChanged $path -height h] } { $path.c configure -height [expr {$h*$dy}] } if { [Widget::hasChanged $path -width w] } { $path.c configure -width [expr {$w*8}] } if { [Widget::hasChanged $path -redraw bool] && $bool } { set upd $data(upd,level) set data(upd,level) 0 _redraw_idle $path $upd } set force [Widget::hasChanged $path -dragendcmd dragend] DragSite::setdrag $path $path.c Tree::_init_drag_cmd $dragend $force DropSite::setdrop $path $path.c Tree::_over_cmd Tree::_drop_cmd return $res } # ---------------------------------------------------------------------------- # Command Tree::cget # ---------------------------------------------------------------------------- proc Tree::cget { path option } { return [Widget::cget $path $option] } # ---------------------------------------------------------------------------- # Command Tree::insert # ---------------------------------------------------------------------------- proc Tree::insert { path index parent node args } { variable $path upvar 0 $path data set node [_node_name $path $node] set node [Widget::nextIndex $path $node] if { [info exists data($node)] } { return -code error "node \"$node\" already exists" } set parent [_node_name $path $parent] if { ![info exists data($parent)] } { return -code error "node \"$parent\" does not exist" } Widget::init Tree::Node $path.$node $args if {[string equal $index "end"]} { lappend data($parent) $node } else { incr index set data($parent) [linsert $data($parent) $index $node] } set data($node) [list $parent] if { [string equal $parent "root"] } { _redraw_idle $path 3 } elseif { [visible $path $parent] } { # parent is visible... if { [Widget::getMegawidgetOption $path.$parent -open] } { # ...and opened -> redraw whole _redraw_idle $path 3 } else { # ...and closed -> redraw cross MergeFlag $path $parent 8 _redraw_idle $path 2 } } return $node } # ---------------------------------------------------------------------------- # Command Tree::itemconfigure # ---------------------------------------------------------------------------- proc Tree::itemconfigure { path node args } { 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" } set result [Widget::configure $path.$node $args] _set_help $path $node if { [visible $path $node] } { set lopt {} set flag 0 foreach opt {-window -image -drawcross -font -text -fill} { set flag [expr {$flag << 1}] if { [Widget::hasChanged $path.$node $opt val] } { set flag [expr {$flag | 1}] } } 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 } { MergeFlag $path $node $flag _redraw_idle $path 2 } } return $result } proc Tree::MergeFlag { path node flag } { variable $path upvar 0 $path data # data(upd,nodes) is a key-val list: emulate a dict by an array array set n $data(upd,nodes) if {![info exists n($node)]} { lappend data(upd,nodes) $node $flag } else { set n($node) [expr {$n($node) | $flag}] set data(upd,nodes) [array get n] } return } # ---------------------------------------------------------------------------- # 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::bindArea # ---------------------------------------------------------------------------- proc Tree::bindArea { path event script } { bind $path.c $event $script } # ---------------------------------------------------------------------------- # Command Tree::bindText # ---------------------------------------------------------------------------- proc Tree::bindText { path event script } { if {[string length $script]} { append script " \[Tree::_get_node_name [list $path] current 2 1\]" } $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 1\]" } $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 set sel 0 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] incr sel [_subdelete $path [list $node]] } } } if {$sel} { # if selection changed, call the selectcommand __call_selectcmd $path } _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" } set nodes [list] foreach node $data(selnodes) { lappend nodes [_node_name_rev $path $node] } return $nodes } 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] } # ---------------------------------------------------------------------------- # Command Tree::index # ---------------------------------------------------------------------------- proc Tree::index { path node } { 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" } set parent [lindex $data($node) 0] return [expr {[lsearch -exact $data($parent) $node] - 1}] } # ---------------------------------------------------------------------------- # Tree::find # Returns the node given a position. # findInfo @x,y ?confine? # lineNumber # ---------------------------------------------------------------------------- proc Tree::find {path findInfo {confine ""}} { if {[regexp -- {^@([0-9]+),([0-9]+)$} $findInfo match x y]} { set x [$path.c canvasx $x] set y [$path.c canvasy $y] } elseif {[regexp -- {^[0-9]+$} $findInfo lineNumber]} { set dy [Widget::getoption $path -deltay] set y [expr {$dy*($lineNumber+0.5)}] set confine "" } else { return -code error "invalid find spec \"$findInfo\"" } set found 0 set region [$path.c bbox all] if {[llength $region]} { set xi [lindex $region 0] set xs [lindex $region 2] foreach id [$path.c find overlapping $xi $y $xs $y] { 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} { if {![string equal $confine ""]} { # test if x stand inside node bbox set padx [_get_node_padx $path $node] set xi [expr {[lindex [$path.c coords n:$node] 0] - $padx}] set xs [lindex [$path.c bbox n:$node] 2] if {$x >= $xi && $x <= $xs} { return [_node_name_rev $path $node] } } else { return [_node_name_rev $path $node] } } return "" } # ---------------------------------------------------------------------------- # Command Tree::line # Returns the line where a node was drawn. # ---------------------------------------------------------------------------- proc Tree::line {path node} { set node [_node_name $path $node] set item [$path.c find withtag n:$node] if {[string length $item]} { set dy [Widget::getoption $path -deltay] set y [lindex [$path.c coords $item] 1] set line [expr {int($y/$dy)}] } else { set line -1 } return $line } # ---------------------------------------------------------------------------- # Command Tree::nodes # ---------------------------------------------------------------------------- proc Tree::nodes { path node {first ""} {last ""} } { 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" } if { ![string length $first] } { return [lrange $data($node) 1 end] } if { ![string length $last] } { return [lindex [lrange $data($node) 1 end] $first] } else { return [lrange [lrange $data($node) 1 end] $first $last] } } # Tree::visiblenodes -- # # Retrieve a list of all the nodes in a tree. # # Arguments: # path tree to retrieve nodes for. # # Results: # nodes list of nodes in the tree. proc Tree::visiblenodes { path } { variable $path upvar 0 $path data # Root is always open (?), so all of its children automatically get added # to the result, and to the stack. set st [lrange $data(root) 1 end] set result $st while {[llength $st]} { set node [lindex $st end] set st [lreplace $st end end] # Danger, danger! Using getMegawidgetOption is fragile, but much # much faster than going through cget. if { [Widget::getMegawidgetOption $path.$node -open] } { set nodes [lrange $data($node) 1 end] set result [concat $result $nodes] set st [concat $st $nodes] } } return $result } # ---------------------------------------------------------------------------- # Command Tree::see # ---------------------------------------------------------------------------- proc Tree::see { path node } { variable $path upvar 0 $path data set node [_node_name $path $node] if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } { after cancel $data(upd,afterid) _redraw_tree $path } set idn [$path.c find withtag n:$node] if { $idn != "" } { Tree::_see $path $idn } } # ---------------------------------------------------------------------------- # Command Tree::opentree # ---------------------------------------------------------------------------- # JDC: added option recursive proc Tree::opentree { path node {recursive 1} } { 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" } _recexpand $path $node 1 $recursive [Widget::getoption $path -opencmd] _redraw_idle $path 3 } # ---------------------------------------------------------------------------- # Command Tree::closetree # ---------------------------------------------------------------------------- proc Tree::closetree { path node {recursive 1} } { 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" } _recexpand $path $node 0 $recursive [Widget::getoption $path -closecmd] _redraw_idle $path 3 } proc Tree::toggle { path node } { if {[$path itemcget $node -open]} { $path closetree $node 0 } else { $path opentree $node 0 } } # ---------------------------------------------------------------------------- # Command Tree::edit # ---------------------------------------------------------------------------- proc Tree::edit { path node text {verifycmd ""} {clickres 0} {select 1}} { variable _edit variable $path upvar 0 $path data set node [_node_name $path $node] if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } { after cancel $data(upd,afterid) _redraw_tree $path } set idn [$path.c find withtag n:$node] if { $idn != "" } { Tree::_see $path $idn set oldfg [$path.c itemcget $idn -fill] set sbg [Widget::getoption $path -selectbackground] set coords [$path.c coords $idn] set x [lindex $coords 0] set y [lindex $coords 1] set bd [expr {[$path.c cget -borderwidth]+[$path.c cget -highlightthickness]}] set w [expr {[winfo width $path] - 2*$bd}] set wmax [expr {[$path.c canvasx $w]-$x}] set _edit(text) $text set _edit(wait) 0 $path.c itemconfigure $idn -fill [Widget::getoption $path -background] $path.c itemconfigure s:$node -fill {} -outline {} set frame [frame $path.edit \ -relief flat -borderwidth 0 -highlightthickness 0 \ -background [Widget::getoption $path -background]] set ent [entry $frame.edit \ -width 0 \ -relief solid \ -borderwidth 1 \ -highlightthickness 0 \ -foreground [Widget::getoption $path.$node -fill] \ -background [Widget::getoption $path -background] \ -selectforeground [Widget::getoption $path -selectforeground] \ -selectbackground $sbg \ -font [Widget::getoption $path.$node -font] \ -textvariable Tree::_edit(text)] pack $ent -ipadx 8 -anchor w set idw [$path.c create window $x $y -window $frame -anchor w] trace variable Tree::_edit(text) w \ [list Tree::_update_edit_size $path $ent $idw $wmax] tkwait visibility $ent grab $frame BWidget::focus set $ent _update_edit_size $path $ent $idw $wmax update if { $select } { $ent selection range 0 end $ent icursor end $ent xview end } bindtags $ent [list $ent Entry] bind $ent <Escape> {set Tree::_edit(wait) 0} bind $ent <Return> {set Tree::_edit(wait) 1} if { $clickres == 0 || $clickres == 1 } { bind $frame <Button> [list set Tree::_edit(wait) $clickres] } set ok 0 while { !$ok } { tkwait variable Tree::_edit(wait) if { !$_edit(wait) || [llength $verifycmd]==0 || [uplevel \#0 $verifycmd [list $_edit(text)]] } { set ok 1 } } trace vdelete Tree::_edit(text) w \ [list Tree::_update_edit_size $path $ent $idw $wmax] grab release $frame BWidget::focus release $ent destroy $frame $path.c delete $idw $path.c itemconfigure $idn -fill $oldfg $path.c itemconfigure s:$node -fill $sbg -outline $sbg if { $_edit(wait) } { return $_edit(text) } } return "" } # ---------------------------------------------------------------------------- # Command Tree::xview # ---------------------------------------------------------------------------- proc Tree::xview { path args } { return [eval [linsert $args 0 $path.c xview]] } # ---------------------------------------------------------------------------- # Command Tree::yview # ---------------------------------------------------------------------------- proc Tree::yview { path args } { return [eval [linsert $args 0 $path.c yview]] } # ---------------------------------------------------------------------------- # Command Tree::_update_edit_size # ---------------------------------------------------------------------------- proc Tree::_update_edit_size { path entry idw wmax args } { set entw [winfo reqwidth $entry] if { $entw+8 >= $wmax } { $path.c itemconfigure $idw -width $wmax } else { $path.c itemconfigure $idw -width 0 } } # ---------------------------------------------------------------------------- # Command Tree::_see # ---------------------------------------------------------------------------- proc Tree::_see { path idn } { set bbox [$path.c bbox $idn] set scrl [$path.c cget -scrollregion] set ymax [lindex $scrl 3] set dy [$path.c cget -yscrollincrement] set yv [$path yview] set yv0 [expr {round([lindex $yv 0]*$ymax/$dy)}] set yv1 [expr {round([lindex $yv 1]*$ymax/$dy)}] set y [expr {int([lindex [$path.c coords $idn] 1]/$dy)}] if { $y < $yv0 } { $path.c yview scroll [expr {$y-$yv0}] units } elseif { $y >= $yv1 } { $path.c yview scroll [expr {$y-$yv1+1}] units } set xmax [lindex $scrl 2] set dx [$path.c cget -xscrollincrement] set xv [$path xview] set x0 [expr {int([lindex $bbox 0]/$dx)}] set xv0 [expr {round([lindex $xv 0]*$xmax/$dx)}] set xv1 [expr {round([lindex $xv 1]*$xmax/$dx)}] if { $x0 >= $xv1 || $x0 < $xv0 } { $path.c xview scroll [expr {$x0-$xv0}] units } } # ---------------------------------------------------------------------------- # Command Tree::_recexpand # ---------------------------------------------------------------------------- # JDC : added option recursive proc Tree::_recexpand { path node expand recursive cmd } { variable $path upvar 0 $path data if { [Widget::getoption $path.$node -open] != $expand } { Widget::setoption $path.$node -open $expand if {[llength $cmd]} { uplevel \#0 $cmd [list $node] } } if { $recursive } { foreach subnode [lrange $data($node) 1 end] { _recexpand $path $subnode $expand $recursive $cmd } } } # ---------------------------------------------------------------------------- # Command Tree::_subdelete # ---------------------------------------------------------------------------- proc Tree::_subdelete { path lnodes } { variable $path upvar 0 $path data set sel $data(selnodes) set selchanged 0 while { [llength $lnodes] } { set lsubnodes [list] foreach node $lnodes { foreach subnode [lrange $data($node) 1 end] { lappend lsubnodes $subnode } unset data($node) set idx [lsearch -exact $sel $node] if { $idx >= 0 } { set sel [lreplace $sel $idx $idx] incr selchanged } if { [set win [Widget::getoption $path.$node -window]] != "" } { destroy $win } Widget::destroy $path.$node } set lnodes $lsubnodes } set data(selnodes) $sel # return number of sel items changes return $selchanged } # ---------------------------------------------------------------------------- # Command Tree::_update_scrollregion # ---------------------------------------------------------------------------- proc Tree::_update_scrollregion { path } { set bd [expr {2*([$path.c cget -borderwidth]+[$path.c cget -highlightthickness])}] set w [expr {[winfo width $path] - $bd}] set h [expr {[winfo height $path] - $bd}] set xinc [$path.c cget -xscrollincrement] set yinc [$path.c cget -yscrollincrement] set bbox [$path.c bbox node] if { [llength $bbox] } { set xs [lindex $bbox 2] set ys [lindex $bbox 3] if { $w < $xs } { set w [expr {$xs + $w % $xinc}] } if { $h < $ys } { set h [expr {$ys + $h % $yinc}] } } $path.c configure -scrollregion [list 0 0 $w $h] if {[Widget::getoption $path -selectfill]} { _redraw_selection $path } } # ---------------------------------------------------------------------------- # Command Tree::_cross_event # ---------------------------------------------------------------------------- proc Tree::_cross_event { path } { variable $path upvar 0 $path data set node [Tree::_get_node_name $path current 1] if { [Widget::getoption $path.$node -open] } { Tree::itemconfigure $path $node -open 0 if {[llength [set cmd [Widget::getoption $path -closecmd]]]} { uplevel \#0 $cmd [list $node] } } else { Tree::itemconfigure $path $node -open 1 if {[llength [set cmd [Widget::getoption $path -opencmd]]]} { uplevel \#0 $cmd [list $node] } } } proc Tree::_draw_cross { path node open x y } { set idc [$path.c find withtag c:$node] if { $open } { set img [Widget::cget $path -crossopenimage] set bmp [Widget::cget $path -crossopenbitmap] } else { set img [Widget::cget $path -crosscloseimage] set bmp [Widget::cget $path -crossclosebitmap] } ## If we already have a cross for this node, we just adjust the image. if {$idc != ""} { if {$img == ""} { $path.c itemconfigure $idc -bitmap $bmp } else { $path.c itemconfigure $idc -image $img } return } ## Create a new image for the cross. If the user has specified an ## image, it overrides a bitmap. if {$img == ""} { $path.c create bitmap $x $y \ -bitmap $bmp \ -background [$path.c cget -background] \ -foreground [Widget::getoption $path -crossfill] \ -tags [list cross c:$node] -anchor c } else { $path.c create image $x $y \ -image $img \ -tags [list cross c:$node] -anchor c } } # ---------------------------------------------------------------------------- # Command Tree::_draw_node # ---------------------------------------------------------------------------- proc Tree::_draw_node { path node x0 y0 deltax deltay padx showlines } { variable $path upvar 0 $path data set x1 [expr {$x0+$deltax+5}] set y1 $y0 if { $showlines } { $path.c create line $x0 $y0 $x1 $y0 \ -fill [Widget::getoption $path -linesfill] \ -stipple [Widget::getoption $path -linestipple] \ -tags line } $path.c create text [expr {$x1+$padx}] $y0 \ -text [Widget::getoption $path.$node -text] \ -fill [Widget::getoption $path.$node -fill] \ -font [Widget::getoption $path.$node -font] \ -anchor w \ -tags [Tree::_get_node_tags $path $node [list node n:$node]] set len [expr {[llength $data($node)] > 1}] set dc [Widget::getoption $path.$node -drawcross] set exp [Widget::getoption $path.$node -open] if { $len && $exp } { set y1 [_draw_subnodes $path [lrange $data($node) 1 end] \ [expr {$x0+$deltax}] $y0 $deltax $deltay $padx $showlines] } if {![string equal $dc "never"] && ($len || [string equal $dc "always"] || [string equal $dc "allways"])} { _draw_cross $path $node $exp $x0 $y0 } if { [set win [Widget::getoption $path.$node -window]] != "" } { set a [Widget::cget $path.$node -anchor] $path.c create window $x1 $y0 -window $win -anchor $a \ -tags [Tree::_get_node_tags $path $node [list win i:$node]] } elseif { [set img [Widget::getoption $path.$node -image]] != "" } { set a [Widget::cget $path.$node -anchor] $path.c create image $x1 $y0 -image $img -anchor $a \ -tags [Tree::_get_node_tags $path $node [list img i:$node]] } set box [$path.c bbox n:$node i:$node] set id [$path.c create rect 0 [lindex $box 1] \ [winfo screenwidth $path] [lindex $box 3] \ -tags [Tree::_get_node_tags $path $node [list box b:$node]] \ -fill {} -outline {}] $path.c lower $id _set_help $path $node return $y1 } # ---------------------------------------------------------------------------- # Command Tree::_draw_subnodes # ---------------------------------------------------------------------------- proc Tree::_draw_subnodes { path nodes x0 y0 deltax deltay padx showlines } { set y1 $y0 foreach node $nodes { set padx [_get_node_padx $path $node] set deltax [_get_node_deltax $path $node] set yp $y1 set y1 [_draw_node $path $node $x0 [expr {$y1+$deltay}] $deltax $deltay $padx $showlines] } # Only draw a line to the invisible root node above the tree widget when # there are multiple top nodes. set len [llength $nodes] if { $showlines && $len && !($y0 < 0 && $len < 2) } { set id [$path.c create line $x0 $y0 $x0 [expr {$yp+$deltay}] \ -fill [Widget::getoption $path -linesfill] \ -stipple [Widget::getoption $path -linestipple] \ -tags line] $path.c lower $id } return $y1 } # ---------------------------------------------------------------------------- # Command Tree::_update_nodes # ---------------------------------------------------------------------------- proc Tree::_update_nodes { path } { variable $path upvar 0 $path data foreach {node flag} $data(upd,nodes) { set idn [$path.c find withtag "n:$node"] if { $idn == "" } { continue } set padx [_get_node_padx $path $node] set deltax [_get_node_deltax $path $node] set c [$path.c coords $idn] set x1 [expr {[lindex $c 0]-$padx}] set x0 [expr {$x1-$deltax-5}] set y0 [lindex $c 1] if { $flag & 48 } { # -window or -image modified set win [Widget::getoption $path.$node -window] set img [Widget::getoption $path.$node -image] set anc [Widget::cget $path.$node -anchor] set idi [$path.c find withtag i:$node] set type [lindex [$path.c gettags $idi] 1] if { [string length $win] } { if { [string equal $type "win"] } { $path.c itemconfigure $idi -window $win } else { $path.c delete $idi $path.c create window $x1 $y0 -window $win -anchor $anc \ -tags [_get_node_tags $path $node [list win i:$node]] } } elseif { [string length $img] } { if { [string equal $type "img"] } { $path.c itemconfigure $idi -image $img } else { $path.c delete $idi $path.c create image $x1 $y0 -image $img -anchor $anc \ -tags [_get_node_tags $path $node [list img i:$node]] } } else { $path.c delete $idi } } if { $flag & 8 } { # -drawcross modified set len [expr {[llength $data($node)] > 1}] set dc [Widget::getoption $path.$node -drawcross] set exp [Widget::getoption $path.$node -open] if {![string equal $dc "never"] && ($len || [string equal $dc "always"] || [string equal $dc "allways"])} { _draw_cross $path $node $exp $x0 $y0 } else { set idc [$path.c find withtag c:$node] $path.c delete $idc } } if { $flag & 7 } { # -font, -text or -fill modified $path.c itemconfigure $idn \ -text [Widget::getoption $path.$node -text] \ -fill [Widget::getoption $path.$node -fill] \ -font [Widget::getoption $path.$node -font] } } } # ---------------------------------------------------------------------------- # Command Tree::_draw_tree # ---------------------------------------------------------------------------- proc Tree::_draw_tree { path } { variable $path upvar 0 $path data $path.c delete all set cursor [$path.c cget -cursor] $path.c configure -cursor watch _draw_subnodes $path [lrange $data(root) 1 end] 8 \ [expr {-[Widget::getoption $path -deltay]/2}] \ [Widget::getoption $path -deltax] \ [Widget::getoption $path -deltay] \ [Widget::getoption $path -padx] \ [Widget::getoption $path -showlines] $path.c configure -cursor $cursor } # ---------------------------------------------------------------------------- # Command Tree::_redraw_tree # ---------------------------------------------------------------------------- proc Tree::_redraw_tree { path } { variable $path upvar 0 $path data if { [Widget::getoption $path -redraw] } { if { $data(upd,level) == 2 } { _update_nodes $path } elseif { $data(upd,level) == 3 } { _draw_tree $path } _redraw_selection $path _update_scrollregion $path set data(upd,nodes) {} set data(upd,level) 0 set data(upd,afterid) "" } } # ---------------------------------------------------------------------------- # Command Tree::_redraw_selection # ---------------------------------------------------------------------------- proc Tree::_redraw_selection { path } { variable $path upvar 0 $path data set selbg [Widget::getoption $path -selectbackground] set selfg [Widget::getoption $path -selectforeground] set fill [Widget::getoption $path -selectfill] if {$fill} { set scroll [$path.c cget -scrollregion] if {[llength $scroll]} { set xmax [expr {[lindex $scroll 2]-1}] } else { set xmax [winfo width $path] } } foreach id [$path.c find withtag sel] { set node [Tree::_get_node_name $path $id 1] $path.c itemconfigure "n:$node" -fill [Widget::getoption $path.$node -fill] } $path.c delete sel foreach node $data(selnodes) { set bbox [$path.c bbox "n:$node"] if { [llength $bbox] } { if {$fill} { # get the image to (if any), as it may have different height set bbox [$path.c bbox "n:$node" "i:$node"] set bbox [list 0 [lindex $bbox 1] $xmax [lindex $bbox 3]] } set id [$path.c create rectangle $bbox -tags [list sel s:$node] \ -fill $selbg -outline $selbg] if {$selfg != ""} { # Don't allow an empty fill - that would be transparent $path.c itemconfigure "n:$node" -fill $selfg } $path.c lower $id } } } # ---------------------------------------------------------------------------- # Command Tree::_redraw_idle # ---------------------------------------------------------------------------- proc Tree::_redraw_idle { path level } { variable $path upvar 0 $path data if { [Widget::getoption $path -redraw] && $data(upd,afterid) == "" } { set data(upd,afterid) [after idle [list Tree::_redraw_tree $path]] } if { $level > $data(upd,level) } { set data(upd,level) $level } return "" } # ---------------------------------------------------------------------------- # Command Tree::_init_drag_cmd # ---------------------------------------------------------------------------- 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 {[llength [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 [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 && [llength [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 [list Tree::_scroll $path $scroll]] } return $data(dnd,afterid) } # ---------------------------------------------------------------------------- # Command Tree::_scroll # ---------------------------------------------------------------------------- proc Tree::_scroll { path scroll } { variable $path upvar 0 $path data set cmd [lindex $scroll 0] set dir [lindex $scroll 1] 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 50 [list Tree::_scroll $path $scroll]] } 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} { # check for an empty tree if {[$win nodes root] eq ""} { return } # 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] event generate $win <<TreeSelect>> 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] event generate $win <<TreeSelect>> 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] event generate $win <<TreeSelect>> return } } "right" { # On a right arrow, if the current node is closed, open it. # If the current node is open, go to its first child if { [string equal $node ""] } { return } set open [$win itemcget $node -open] if { $open } { if { [llength [$win nodes $node]] } { 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] event generate $win <<TreeSelect>> return } } } else { $win itemconfigure $node -open 1 if {[llength [set cmd [Widget::getoption $win -opencmd]]]} { uplevel \#0 $cmd [list $node] } return } } "left" { # On a left arrow, if the current node is open, close it. # If the current node is closed, go to its parent. if { [string equal $node ""] } { return } set open [$win itemcget $node -open] if { $open } { $win itemconfigure $node -open 0 if {[llength [set cmd [Widget::getoption $win -closecmd]]]} { uplevel \#0 $cmd [list $node] } return } else { set parent [$win parent $node] if { [string equal $parent "root"] } { set parent $node } else { while { ![$win itemcget $parent -selectable] } { set parent [$win parent $parent] if { [string equal $parent "root"] } { set parent $node break } } } $win selection set $parent _set_current_node $win $parent $win see $parent event generate $win <<TreeSelect>> return } } "space" { if { [string equal $node ""] } { return } set open [$win itemcget $node -open] if { [llength [$win nodes $node]] } { # Toggle the open status of the chosen node. $win itemconfigure $node -open [expr {$open?0:1}] if {$open} { # Node was open, is now closed. Call the close-cmd if {[llength [set cmd [Widget::getoption $win -closecmd]]]} { uplevel \#0 $cmd [list $node] } } else { # Node was closed, is now open. Call the open-cmd if {[llength [set cmd [Widget::getoption $win -opencmd]]]} { uplevel \#0 $cmd [list $node] } } } } } return } # Tree::_get_current_node -- # # Get the current node for either single or multiple # node selection trees. If the tree allows for # multiple selection, return the cursor node. Otherwise, # if there is a selection, return the first node in the # list. If there is no selection, return the root node. # # arguments: # win name of the tree widget # # Results: # The current node. proc Tree::_get_current_node {win} { if {[info exists selectTree::selectCursor($win)]} { set result $selectTree::selectCursor($win) } elseif {[llength [set selList [$win selection get]]]} { set result [lindex $selList 0] } else { set result "" } return $result } # Tree::_set_current_node -- # # Set the current node for either single or multiple # node selection trees. # # arguments: # win Name of the tree widget # node The current node. # # Results: # None. proc Tree::_set_current_node {win node} { if {[info exists selectTree::selectCursor($win)]} { set selectTree::selectCursor($win) $node } return } # Tree::_get_node_name -- # # Given a canvas item, get the name of the tree node represented by that # item. # # Arguments: # path tree to query # item Optional canvas item to examine; if omitted, # defaults to "current" # tagindex Optional tag index, since the n:nodename tag is not # in the same spot for all canvas items. If omitted, # defaults to "end-1", so it works with "current" item. # # Results: # node name of the tree node. proc Tree::_get_node_name {path {item current} {tagindex end-1} {truename 0}} { set node [string range [lindex [$path.c gettags $item] $tagindex] 2 end] if {$truename} { return [_node_name_rev $path $node] } return $node } # Tree::_get_node_padx -- # # Given a node in the tree, return it's padx value. If the value is # less than 0, default to the padx of the entire tree. # # Arguments: # path Tree to query # node Node in the tree # # Results: # padx The numeric padx value proc Tree::_get_node_padx {path node} { set padx [Widget::getoption $path.$node -padx] if {$padx < 0} { set padx [Widget::getoption $path -padx] } return $padx } # Tree::_get_node_deltax -- # # Given a node in the tree, return it's deltax value. If the value is # less than 0, default to the deltax of the entire tree. # # Arguments: # path Tree to query # node Node in the tree # # Results: # deltax The numeric deltax value proc Tree::_get_node_deltax {path node} { set deltax [Widget::getoption $path.$node -deltax] if {$deltax < 0} { set deltax [Widget::getoption $path -deltax] } return $deltax } # Tree::_get_node_tags -- # # Given a node in the tree, return a list of tags to apply to its # canvas item. # # Arguments: # path Tree to query # node Node in the tree # tags A list of tags to add to the final list # # Results: # list The list of tags to apply to the canvas item proc Tree::_get_node_tags {path node {tags ""}} { eval [linsert $tags 0 lappend list TreeItemSentinal] if {[Widget::getoption $path.$node -helptext] == "" && [Widget::getoption $path.$node -helpcmd] == ""} { return $list } switch -- [Widget::getoption $path.$node -helptype] { balloon { lappend list BwHelpBalloon } variable { lappend list BwHelpVariable } } return $list } # Tree::_set_help -- # # Register dynamic help for a node in the tree. # # Arguments: # path Tree to query # node Node in the tree # force Optional argument to force a reset of the help # # Results: # none proc Tree::_set_help { path node } { Widget::getVariable $path help set item $path.$node set opts [list -helptype -helptext -helpvar -helpcmd] foreach {cty ctx cv cc} [eval [linsert $opts 0 Widget::hasChangedX $item]] break set text [Widget::getoption $item -helptext] set cmd [Widget::getoption $item -helpcmd] ## If we've never set help for this item before, and text or cmd is not ## blank, we need to setup help. We also need to reset help if any of the ## options have changed. if { (![info exists help($node)] && ($text != "" || $cmd != "")) || $cty || $ctx || $cv } { set help($node) 1 set type [Widget::getoption $item -helptype] set var [Widget::getoption $item -helpvar] DynamicHelp::add $path.c -item n:$node -type $type -text $text -variable $var -command $cmd DynamicHelp::add $path.c -item i:$node -type $type -text $text -variable $var -command $cmd DynamicHelp::add $path.c -item b:$node -type $type -text $text -variable $var -command $cmd } } proc Tree::_mouse_select { path cmd args } { eval [linsert $args 0 selection $path $cmd] switch -- $cmd { "add" - "clear" - "remove" - "set" - "toggle" { event generate $path <<TreeSelect>> } } } proc Tree::_node_name { path node } { # Make sure node names are safe as tags and variable names set map [list & \1 | \2 ^ \3 ! \4 :: \5] return [string map $map $node] } proc Tree::_node_name_rev { path node } { # Allow reverse interpretation of node names set map [list \1 & \2 | \3 ^ \4 ! \5 ::] return [string map $map $node] } # ---------------------------------------------------------------------------- # Command Tree::_destroy # ---------------------------------------------------------------------------- proc Tree::_destroy { path } { variable $path upvar 0 $path data if { $data(upd,afterid) != "" } { after cancel $data(upd,afterid) } if { $data(dnd,afterid) != "" } { after cancel $data(dnd,afterid) } _subdelete $path [lrange $data(root) 1 end] Widget::destroy $path unset data }