1# ---------------------------------------------------------------------------- 2# tree.tcl 3# This file is part of Unifix BWidget Toolkit 4# $Id: tree.tcl,v 1.62 2009/09/08 20:46:40 oberdorfer Exp $ 5# ---------------------------------------------------------------------------- 6# Index of commands: 7# - Tree::create 8# - Tree::configure 9# - Tree::cget 10# - Tree::insert 11# - Tree::itemconfigure 12# - Tree::itemcget 13# - Tree::bindArea 14# - Tree::bindText 15# - Tree::bindImage 16# - Tree::delete 17# - Tree::move 18# - Tree::reorder 19# - Tree::selection 20# - Tree::exists 21# - Tree::parent 22# - Tree::index 23# - Tree::nodes 24# - Tree::see 25# - Tree::opentree 26# - Tree::closetree 27# - Tree::edit 28# - Tree::xview 29# - Tree::yview 30# - Tree::_update_edit_size 31# - Tree::_destroy 32# - Tree::_see 33# - Tree::_recexpand 34# - Tree::_subdelete 35# - Tree::_update_scrollregion 36# - Tree::_cross_event 37# - Tree::_draw_node 38# - Tree::_draw_subnodes 39# - Tree::_update_nodes 40# - Tree::_draw_tree 41# - Tree::_redraw_tree 42# - Tree::_redraw_selection 43# - Tree::_redraw_idle 44# - Tree::_drag_cmd 45# - Tree::_drop_cmd 46# - Tree::_over_cmd 47# - Tree::_auto_scroll 48# - Tree::_scroll 49# - Tree::_themechanged 50# ---------------------------------------------------------------------------- 51 52namespace eval Tree { 53 Widget::define Tree tree DragSite DropSite DynamicHelp 54 55 namespace eval Node { 56 Widget::declare Tree::Node { 57 {-text String "" 0} 58 {-font String "TkTextFont" 0} 59 {-image TkResource "" 0 label} 60 {-window String "" 0} 61 {-fill Color "SystemWindowText" 0} 62 {-data String "" 0} 63 {-open Boolean 0 0} 64 {-selectable Boolean 1 0} 65 {-drawcross Enum auto 0 {auto always never allways}} 66 {-padx Int -1 0 "%d >= -1"} 67 {-deltax Int -1 0 "%d >= -1"} 68 {-anchor String "w" 0 ""} 69 } 70 } 71 72 DynamicHelp::include Tree::Node balloon 73 74 Widget::tkinclude Tree canvas .c \ 75 remove { 76 -insertwidth -insertbackground -insertborderwidth -insertofftime 77 -insertontime -selectborderwidth -closeenough -confine -scrollregion 78 -xscrollincrement -yscrollincrement -width -height 79 } \ 80 initialize { 81 -relief sunken -borderwidth 2 -takefocus 1 82 -highlightthickness 1 -width 200 83 } 84 85 Widget::declare Tree { 86 {-deltax Int 10 0 "%d >= 0"} 87 {-deltay Int 15 0 "%d >= 0"} 88 {-padx Int 20 0 "%d >= 0"} 89 {-background Color "SystemWindow" 0} 90 {-selectbackground Color "SystemHighlight" 0} 91 {-selectforeground Color "SystemHighlightText" 0} 92 {-selectcommand String "" 0} 93 {-width TkResource "" 0 listbox} 94 {-height TkResource "" 0 listbox} 95 {-selectfill Boolean 0 0} 96 {-showlines Boolean 1 0} 97 {-linesfill Color "SystemWindowText" 0} 98 {-linestipple TkResource "" 0 {label -bitmap}} 99 {-crossfill Color "SystemWindowText" 0} 100 {-redraw Boolean 1 0} 101 {-opencmd String "" 0} 102 {-closecmd String "" 0} 103 {-dropovermode Flag "wpn" 0 "wpn"} 104 {-bg Synonym -background} 105 106 {-crossopenimage String "" 0} 107 {-crosscloseimage String "" 0} 108 {-crossopenbitmap String "" 0} 109 {-crossclosebitmap String "" 0} 110 } 111 112 DragSite::include Tree "TREE_NODE" 1 113 DropSite::include Tree { 114 TREE_NODE {copy {} move {}} 115 } 116 117 Widget::addmap Tree "" .c {-deltay -yscrollincrement} 118 119 # Trees on windows have a white (system window) background 120 if { $::tcl_platform(platform) == "windows" } { 121 option add *Tree.c.background SystemWindow widgetDefault 122 option add *TreeNode.fill SystemWindowText widgetDefault 123 } 124 125 bind Tree <FocusIn> [list after idle {BWidget::refocus %W %W.c}] 126 bind Tree <Destroy> [list Tree::_destroy %W] 127 bind Tree <Configure> [list Tree::_update_scrollregion %W] 128 129 130 bind TreeSentinalStart <Button-1> { 131 if { $::Tree::sentinal(%W) } { 132 set ::Tree::sentinal(%W) 0 133 break 134 } 135 } 136 137 bind TreeSentinalEnd <Button-1> { 138 set ::Tree::sentinal(%W) 0 139 } 140 141 bind TreeFocus <Button-1> [list focus %W] 142 143 if {[lsearch [bindtags .] TreeThemeChanged] < 0} { 144 bindtags . [linsert [bindtags .] 1 TreeThemeChanged] 145 } 146 147 variable _edit 148} 149 150 151# ---------------------------------------------------------------------------- 152# Command Tree::create 153# ---------------------------------------------------------------------------- 154proc Tree::create { path args } { 155 variable $path 156 upvar 0 $path data 157 158 Widget::init Tree $path $args 159 set ::Tree::sentinal($path.c) 0 160 161 if {[Widget::cget $path -crossopenbitmap] == ""} { 162 set file [file join $::BWIDGET::LIBRARY images "minus.xbm"] 163 Widget::configure $path [list -crossopenbitmap @$file] 164 } 165 if {[Widget::cget $path -crossclosebitmap] == ""} { 166 set file [file join $::BWIDGET::LIBRARY images "plus.xbm"] 167 Widget::configure $path [list -crossclosebitmap @$file] 168 } 169 170 set data(root) {{}} 171 set data(selnodes) {} 172 set data(upd,level) 0 173 set data(upd,nodes) {} 174 set data(upd,afterid) "" 175 set data(dnd,scroll) "" 176 set data(dnd,afterid) "" 177 set data(dnd,selnodes) {} 178 set data(dnd,node) "" 179 180 frame $path -class Tree -bd 0 -highlightthickness 0 -relief flat \ 181 -takefocus 0 182 # For 8.4+ we don't want to inherit the padding 183 catch {$path configure -padx 0 -pady 0} 184 eval [list canvas $path.c] [Widget::subcget $path .c] -xscrollincrement 8 185 bindtags $path.c [list TreeSentinalStart TreeFocus $path.c Canvas \ 186 [winfo toplevel $path] all TreeSentinalEnd] 187 pack $path.c -expand yes -fill both 188 $path.c bind cross <ButtonPress-1> [list Tree::_cross_event $path] 189 190 # Added by ericm@scriptics.com 191 # These allow keyboard traversal of the tree 192 bind $path.c <KeyPress-Up> [list Tree::_keynav up $path] 193 bind $path.c <KeyPress-Down> [list Tree::_keynav down $path] 194 bind $path.c <KeyPress-Right> [list Tree::_keynav right $path] 195 bind $path.c <KeyPress-Left> [list Tree::_keynav left $path] 196 bind $path.c <KeyPress-space> [list +Tree::_keynav space $path] 197 198 # These allow keyboard control of the scrolling 199 bind $path.c <Control-KeyPress-Up> [list $path.c yview scroll -1 units] 200 bind $path.c <Control-KeyPress-Down> [list $path.c yview scroll 1 units] 201 bind $path.c <Control-KeyPress-Left> [list $path.c xview scroll -1 units] 202 bind $path.c <Control-KeyPress-Right> [list $path.c xview scroll 1 units] 203 # ericm@scriptics.com 204 205 BWidget::bindMouseWheel $path.c 206 BWidget::bindMiddleMouseMovement $path.c 207 208 DragSite::setdrag $path $path.c Tree::_init_drag_cmd \ 209 [Widget::cget $path -dragendcmd] 1 210 DropSite::setdrop $path $path.c Tree::_over_cmd Tree::_drop_cmd 1 211 212 Widget::create Tree $path 213 214 set w [Widget::cget $path -width] 215 set h [Widget::cget $path -height] 216 set dy [Widget::cget $path -deltay] 217 $path.c configure -width [expr {$w*8}] -height [expr {$h*$dy}] 218 219 # ericm 220 # Bind <Button-1> to select the clicked node -- no reason not to, right? 221 222 ## Bind button 1 to select the node via the _mouse_select command. 223 ## This command will generate the proper <<TreeSelect>> virtual event 224 ## when necessary. 225 set selectcmd Tree::_mouse_select 226 Tree::bindText $path <Button-1> [list $selectcmd $path set] 227 Tree::bindImage $path <Button-1> [list $selectcmd $path set] 228 Tree::bindText $path <Control-Button-1> [list $selectcmd $path toggle] 229 Tree::bindImage $path <Control-Button-1> [list $selectcmd $path toggle] 230 231 # Add sentinal bindings for double-clicking on items, to handle the 232 # gnarly Tk bug wherein: 233 # ButtonClick 234 # ButtonClick 235 # On a canvas item translates into button click on the item, button click 236 # on the canvas, double-button on the item, single button click on the 237 # canvas (which can happen if the double-button on the item causes some 238 # other event to be handled in between when the button clicks are examined 239 # for the canvas) 240 $path.c bind TreeItemSentinal <Double-Button-1> \ 241 [list set ::Tree::sentinal($path.c) 1] 242 # ericm 243 244 bind TreeThemeChanged <<ThemeChanged>> \ 245 "+ [namespace current]::_themechanged $path" 246 247 return $path 248} 249 250 251# ---------------------------------------------------------------------------- 252# Command Tree::configure 253# ---------------------------------------------------------------------------- 254proc Tree::configure { path args } { 255 variable $path 256 upvar 0 $path data 257 258 set res [Widget::configure $path $args] 259 260 set ch1 [expr {[Widget::hasChanged $path -deltax val] | 261 [Widget::hasChanged $path -deltay dy] | 262 [Widget::hasChanged $path -padx val] | 263 [Widget::hasChanged $path -showlines val]}] 264 265 set ch2 [expr {[Widget::hasChanged $path -selectbackground val] | 266 [Widget::hasChanged $path -selectforeground val]}] 267 268 if { [Widget::hasChanged $path -linesfill fill] | 269 [Widget::hasChanged $path -linestipple stipple] } { 270 $path.c itemconfigure line -fill $fill -stipple $stipple 271 } 272 273 if { [Widget::hasChanged $path -crossfill fill] } { 274 $path.c itemconfigure cross -foreground $fill 275 } 276 277 if {[Widget::hasChanged $path -selectfill fill]} { 278 # Make sure that the full-width boxes have either all or none 279 # of the standard node bindings 280 if {$fill} { 281 foreach event [$path.c bind "node"] { 282 $path.c bind "box" $event [$path.c bind "node" $event] 283 } 284 } else { 285 foreach event [$path.c bind "node"] { 286 $path.c bind "box" $event {} 287 } 288 } 289 } 290 291 if { $ch1 } { 292 _redraw_idle $path 3 293 } elseif { $ch2 } { 294 _redraw_idle $path 1 295 } 296 297 if { [Widget::hasChanged $path -height h] } { 298 $path.c configure -height [expr {$h*$dy}] 299 } 300 if { [Widget::hasChanged $path -width w] } { 301 $path.c configure -width [expr {$w*8}] 302 } 303 304 if { [Widget::hasChanged $path -redraw bool] && $bool } { 305 set upd $data(upd,level) 306 set data(upd,level) 0 307 _redraw_idle $path $upd 308 } 309 310 set force [Widget::hasChanged $path -dragendcmd dragend] 311 DragSite::setdrag $path $path.c Tree::_init_drag_cmd $dragend $force 312 DropSite::setdrop $path $path.c Tree::_over_cmd Tree::_drop_cmd 313 314 return $res 315} 316 317 318# ---------------------------------------------------------------------------- 319# Command Tree::cget 320# ---------------------------------------------------------------------------- 321proc Tree::cget { path option } { 322 return [Widget::cget $path $option] 323} 324 325 326# ---------------------------------------------------------------------------- 327# Command Tree::insert 328# ---------------------------------------------------------------------------- 329proc Tree::insert { path index parent node args } { 330 variable $path 331 upvar 0 $path data 332 333 set node [_node_name $path $node] 334 set node [Widget::nextIndex $path $node] 335 336 if { [info exists data($node)] } { 337 return -code error "node \"$node\" already exists" 338 } 339 set parent [_node_name $path $parent] 340 if { ![info exists data($parent)] } { 341 return -code error "node \"$parent\" does not exist" 342 } 343 344 Widget::init Tree::Node $path.$node $args 345 if {[string equal $index "end"]} { 346 lappend data($parent) $node 347 } else { 348 incr index 349 set data($parent) [linsert $data($parent) $index $node] 350 } 351 set data($node) [list $parent] 352 353 if { [string equal $parent "root"] } { 354 _redraw_idle $path 3 355 } elseif { [visible $path $parent] } { 356 # parent is visible... 357 if { [Widget::getMegawidgetOption $path.$parent -open] } { 358 # ...and opened -> redraw whole 359 _redraw_idle $path 3 360 } else { 361 # ...and closed -> redraw cross 362 lappend data(upd,nodes) $parent 8 363 _redraw_idle $path 2 364 } 365 } 366 367 return $node 368} 369 370 371# ---------------------------------------------------------------------------- 372# Command Tree::itemconfigure 373# ---------------------------------------------------------------------------- 374proc Tree::itemconfigure { path node args } { 375 variable $path 376 upvar 0 $path data 377 378 set node [_node_name $path $node] 379 if { [string equal $node "root"] || ![info exists data($node)] } { 380 return -code error "node \"$node\" does not exist" 381 } 382 383 set result [Widget::configure $path.$node $args] 384 385 _set_help $path $node 386 387 if { [visible $path $node] } { 388 set lopt {} 389 set flag 0 390 foreach opt {-window -image -drawcross -font -text -fill} { 391 set flag [expr {$flag << 1}] 392 if { [Widget::hasChanged $path.$node $opt val] } { 393 set flag [expr {$flag | 1}] 394 } 395 } 396 397 if { [Widget::hasChanged $path.$node -open val] } { 398 if {[llength $data($node)] > 1} { 399 # node have subnodes - full redraw 400 _redraw_idle $path 3 401 } else { 402 # force a redraw of the plus/minus sign 403 set flag [expr {$flag | 8}] 404 } 405 } 406 407 if {$data(upd,level) < 3 && [Widget::hasChanged $path.$node -padx x]} { 408 _redraw_idle $path 3 409 } 410 411 if { $data(upd,level) < 3 && $flag } { 412 if { [set idx [lsearch -exact $data(upd,nodes) $node]] == -1 } { 413 lappend data(upd,nodes) $node $flag 414 } else { 415 incr idx 416 set flag [expr {[lindex $data(upd,nodes) $idx] | $flag}] 417 set data(upd,nodes) [lreplace $data(upd,nodes) $idx $idx $flag] 418 } 419 _redraw_idle $path 2 420 } 421 } 422 return $result 423} 424 425 426# ---------------------------------------------------------------------------- 427# Command Tree::itemcget 428# ---------------------------------------------------------------------------- 429proc Tree::itemcget { path node option } { 430 # Instead of upvar'ing $path as data for this test, just directly refer to 431 # it, as that is faster. 432 set node [_node_name $path $node] 433 if { [string equal $node "root"] || \ 434 ![info exists ::Tree::${path}($node)] } { 435 return -code error "node \"$node\" does not exist" 436 } 437 438 return [Widget::cget $path.$node $option] 439} 440 441# ---------------------------------------------------------------------------- 442# Command Tree::bindArea 443# ---------------------------------------------------------------------------- 444proc Tree::bindArea { path event script } { 445 bind $path.c $event $script 446} 447 448# ---------------------------------------------------------------------------- 449# Command Tree::bindText 450# ---------------------------------------------------------------------------- 451proc Tree::bindText { path event script } { 452 if {[string length $script]} { 453 append script " \[Tree::_get_node_name [list $path] current 2 1\]" 454 } 455 $path.c bind "node" $event $script 456 if {[Widget::getoption $path -selectfill]} { 457 $path.c bind "box" $event $script 458 } else { 459 $path.c bind "box" $event {} 460 } 461} 462 463 464# ---------------------------------------------------------------------------- 465# Command Tree::bindImage 466# ---------------------------------------------------------------------------- 467proc Tree::bindImage { path event script } { 468 if {[string length $script]} { 469 append script " \[Tree::_get_node_name [list $path] current 2 1\]" 470 } 471 $path.c bind "img" $event $script 472 if {[Widget::getoption $path -selectfill]} { 473 $path.c bind "box" $event $script 474 } else { 475 $path.c bind "box" $event {} 476 } 477} 478 479 480# ---------------------------------------------------------------------------- 481# Command Tree::delete 482# ---------------------------------------------------------------------------- 483proc Tree::delete { path args } { 484 variable $path 485 upvar 0 $path data 486 487 set sel 0 488 foreach lnodes $args { 489 foreach node $lnodes { 490 set node [_node_name $path $node] 491 if { ![string equal $node "root"] && [info exists data($node)] } { 492 set parent [lindex $data($node) 0] 493 set idx [lsearch -exact $data($parent) $node] 494 set data($parent) [lreplace $data($parent) $idx $idx] 495 incr sel [_subdelete $path [list $node]] 496 } 497 } 498 } 499 if {$sel} { 500 # if selection changed, call the selectcommand 501 __call_selectcmd $path 502 } 503 504 _redraw_idle $path 3 505} 506 507 508# ---------------------------------------------------------------------------- 509# Command Tree::move 510# ---------------------------------------------------------------------------- 511proc Tree::move { path parent node index } { 512 variable $path 513 upvar 0 $path data 514 515 set node [_node_name $path $node] 516 if { [string equal $node "root"] || ![info exists data($node)] } { 517 return -code error "node \"$node\" does not exist" 518 } 519 if { ![info exists data($parent)] } { 520 return -code error "node \"$parent\" does not exist" 521 } 522 set p $parent 523 while { ![string equal $p "root"] } { 524 if { [string equal $p $node] } { 525 return -code error "node \"$parent\" is a descendant of \"$node\"" 526 } 527 set p [parent $path $p] 528 } 529 530 set oldp [lindex $data($node) 0] 531 set idx [lsearch -exact $data($oldp) $node] 532 set data($oldp) [lreplace $data($oldp) $idx $idx] 533 set data($node) [concat [list $parent] [lrange $data($node) 1 end]] 534 if { [string equal $index "end"] } { 535 lappend data($parent) $node 536 } else { 537 incr index 538 set data($parent) [linsert $data($parent) $index $node] 539 } 540 if { ([string equal $oldp "root"] || 541 ([visible $path $oldp] && [Widget::getoption $path.$oldp -open])) || 542 ([string equal $parent "root"] || 543 ([visible $path $parent] && [Widget::getoption $path.$parent -open])) } { 544 _redraw_idle $path 3 545 } 546} 547 548 549# ---------------------------------------------------------------------------- 550# Command Tree::reorder 551# ---------------------------------------------------------------------------- 552proc Tree::reorder { path node neworder } { 553 variable $path 554 upvar 0 $path data 555 556 set node [_node_name $path $node] 557 if { ![info exists data($node)] } { 558 return -code error "node \"$node\" does not exist" 559 } 560 set children [lrange $data($node) 1 end] 561 if { [llength $children] } { 562 set children [BWidget::lreorder $children $neworder] 563 set data($node) [linsert $children 0 [lindex $data($node) 0]] 564 if { [visible $path $node] && [Widget::getoption $path.$node -open] } { 565 _redraw_idle $path 3 566 } 567 } 568} 569 570 571# ---------------------------------------------------------------------------- 572# Command Tree::selection 573# ---------------------------------------------------------------------------- 574proc Tree::selection { path cmd args } { 575 variable $path 576 upvar 0 $path data 577 578 switch -- $cmd { 579 toggle { 580 foreach node $args { 581 set node [_node_name $path $node] 582 if {![info exists data($node)]} { 583 return -code error \ 584 "$path selection toggle: Cannot toggle unknown node \"$node\"." 585 } 586 } 587 foreach node $args { 588 set node [_node_name $path $node] 589 if {[$path selection includes $node]} { 590 $path selection remove $node 591 } else { 592 $path selection add $node 593 } 594 } 595 } 596 set { 597 foreach node $args { 598 set node [_node_name $path $node] 599 if {![info exists data($node)]} { 600 return -code error \ 601 "$path selection set: Cannot select unknown node \"$node\"." 602 } 603 } 604 set data(selnodes) {} 605 foreach node $args { 606 set node [_node_name $path $node] 607 if { [Widget::getoption $path.$node -selectable] } { 608 if { [lsearch -exact $data(selnodes) $node] == -1 } { 609 lappend data(selnodes) $node 610 } 611 } 612 } 613 __call_selectcmd $path 614 } 615 add { 616 foreach node $args { 617 set node [_node_name $path $node] 618 if {![info exists data($node)]} { 619 return -code error \ 620 "$path selection add: Cannot select unknown node \"$node\"." 621 } 622 } 623 foreach node $args { 624 set node [_node_name $path $node] 625 if { [Widget::getoption $path.$node -selectable] } { 626 if { [lsearch -exact $data(selnodes) $node] == -1 } { 627 lappend data(selnodes) $node 628 } 629 } 630 } 631 __call_selectcmd $path 632 } 633 range { 634 # Here's our algorithm: 635 # make a list of all nodes, then take the range from node1 636 # to node2 and select those nodes 637 # 638 # This works because of how this widget handles redraws: 639 # The tree is always completely redrawn, and always from 640 # top to bottom. So the list of visible nodes *is* the 641 # list of nodes, and we can use that to decide which nodes 642 # to select. 643 644 if {[llength $args] != 2} { 645 return -code error \ 646 "wrong#args: Expected $path selection range node1 node2" 647 } 648 649 foreach {node1 node2} $args break 650 651 set node1 [_node_name $path $node1] 652 set node2 [_node_name $path $node2] 653 if {![info exists data($node1)]} { 654 return -code error \ 655 "$path selection range: Cannot start range at unknown node \"$node1\"." 656 } 657 if {![info exists data($node2)]} { 658 return -code error \ 659 "$path selection range: Cannot end range at unknown node \"$node2\"." 660 } 661 662 set nodes {} 663 foreach nodeItem [$path.c find withtag node] { 664 set node [Tree::_get_node_name $path $nodeItem 2] 665 if { [Widget::getoption $path.$node -selectable] } { 666 lappend nodes $node 667 } 668 } 669 # surles: Set the root string to the first element on the list. 670 if {$node1 == "root"} { 671 set node1 [lindex $nodes 0] 672 } 673 if {$node2 == "root"} { 674 set node2 [lindex $nodes 0] 675 } 676 677 # Find the first visible ancestor of node1, starting with node1 678 while {[set index1 [lsearch -exact $nodes $node1]] == -1} { 679 set node1 [lindex $data($node1) 0] 680 } 681 # Find the first visible ancestor of node2, starting with node2 682 while {[set index2 [lsearch -exact $nodes $node2]] == -1} { 683 set node2 [lindex $data($node2) 0] 684 } 685 # If the nodes were given in backwards order, flip the 686 # indices now 687 if { $index2 < $index1 } { 688 incr index1 $index2 689 set index2 [expr {$index1 - $index2}] 690 set index1 [expr {$index1 - $index2}] 691 } 692 set data(selnodes) [lrange $nodes $index1 $index2] 693 __call_selectcmd $path 694 } 695 remove { 696 foreach node $args { 697 set node [_node_name $path $node] 698 if { [set idx [lsearch -exact $data(selnodes) $node]] != -1 } { 699 set data(selnodes) [lreplace $data(selnodes) $idx $idx] 700 } 701 } 702 __call_selectcmd $path 703 } 704 clear { 705 if {[llength $args] != 0} { 706 return -code error \ 707 "wrong#args: Expected $path selection clear" 708 } 709 set data(selnodes) {} 710 __call_selectcmd $path 711 } 712 get { 713 if {[llength $args] != 0} { 714 return -code error \ 715 "wrong#args: Expected $path selection get" 716 } 717 set nodes [list] 718 foreach node $data(selnodes) { 719 lappend nodes [_node_name_rev $path $node] 720 } 721 return $nodes 722 } 723 includes { 724 if {[llength $args] != 1} { 725 return -code error \ 726 "wrong#args: Expected $path selection includes node" 727 } 728 set node [lindex $args 0] 729 set node [_node_name $path $node] 730 return [expr {[lsearch -exact $data(selnodes) $node] != -1}] 731 } 732 default { 733 return 734 } 735 } 736 _redraw_idle $path 1 737} 738 739 740proc Tree::getcanvas { path } { 741 return $path.c 742} 743 744 745proc Tree::__call_selectcmd { path } { 746 variable $path 747 upvar 0 $path data 748 749 set selectcmd [Widget::getoption $path -selectcommand] 750 if {[llength $selectcmd]} { 751 lappend selectcmd $path 752 lappend selectcmd $data(selnodes) 753 uplevel \#0 $selectcmd 754 } 755 return 756} 757 758# ---------------------------------------------------------------------------- 759# Command Tree::exists 760# ---------------------------------------------------------------------------- 761proc Tree::exists { path node } { 762 variable $path 763 upvar 0 $path data 764 765 set node [_node_name $path $node] 766 return [info exists data($node)] 767} 768 769 770# ---------------------------------------------------------------------------- 771# Command Tree::visible 772# ---------------------------------------------------------------------------- 773proc Tree::visible { path node } { 774 set node [_node_name $path $node] 775 set idn [$path.c find withtag n:$node] 776 return [llength $idn] 777} 778 779 780# ---------------------------------------------------------------------------- 781# Command Tree::parent 782# ---------------------------------------------------------------------------- 783proc Tree::parent { path node } { 784 variable $path 785 upvar 0 $path data 786 787 set node [_node_name $path $node] 788 if { ![info exists data($node)] } { 789 return -code error "node \"$node\" does not exist" 790 } 791 return [lindex $data($node) 0] 792} 793 794 795# ---------------------------------------------------------------------------- 796# Command Tree::index 797# ---------------------------------------------------------------------------- 798proc Tree::index { path node } { 799 variable $path 800 upvar 0 $path data 801 802 set node [_node_name $path $node] 803 if { [string equal $node "root"] || ![info exists data($node)] } { 804 return -code error "node \"$node\" does not exist" 805 } 806 set parent [lindex $data($node) 0] 807 return [expr {[lsearch -exact $data($parent) $node] - 1}] 808} 809 810 811# ---------------------------------------------------------------------------- 812# Tree::find 813# Returns the node given a position. 814# findInfo @x,y ?confine? 815# lineNumber 816# ---------------------------------------------------------------------------- 817proc Tree::find {path findInfo {confine ""}} { 818 if {[regexp -- {^@([0-9]+),([0-9]+)$} $findInfo match x y]} { 819 set x [$path.c canvasx $x] 820 set y [$path.c canvasy $y] 821 } elseif {[regexp -- {^[0-9]+$} $findInfo lineNumber]} { 822 set dy [Widget::getoption $path -deltay] 823 set y [expr {$dy*($lineNumber+0.5)}] 824 set confine "" 825 } else { 826 return -code error "invalid find spec \"$findInfo\"" 827 } 828 829 set found 0 830 set region [$path.c bbox all] 831 if {[llength $region]} { 832 set xi [lindex $region 0] 833 set xs [lindex $region 2] 834 foreach id [$path.c find overlapping $xi $y $xs $y] { 835 set ltags [$path.c gettags $id] 836 set item [lindex $ltags 1] 837 if { [string equal $item "node"] || 838 [string equal $item "img"] || 839 [string equal $item "win"] } { 840 # item is the label or image/window of the node 841 set node [Tree::_get_node_name $path $id 2] 842 set found 1 843 break 844 } 845 } 846 } 847 848 if {$found} { 849 if {![string equal $confine ""]} { 850 # test if x stand inside node bbox 851 set padx [_get_node_padx $path $node] 852 set xi [expr {[lindex [$path.c coords n:$node] 0] - $padx}] 853 set xs [lindex [$path.c bbox n:$node] 2] 854 if {$x >= $xi && $x <= $xs} { 855 return [_node_name_rev $path $node] 856 } 857 } else { 858 return [_node_name_rev $path $node] 859 } 860 } 861 return "" 862} 863 864 865# ---------------------------------------------------------------------------- 866# Command Tree::line 867# Returns the line where a node was drawn. 868# ---------------------------------------------------------------------------- 869proc Tree::line {path node} { 870 set node [_node_name $path $node] 871 set item [$path.c find withtag n:$node] 872 if {[string length $item]} { 873 set dy [Widget::getoption $path -deltay] 874 set y [lindex [$path.c coords $item] 1] 875 set line [expr {int($y/$dy)}] 876 } else { 877 set line -1 878 } 879 return $line 880} 881 882 883# ---------------------------------------------------------------------------- 884# Command Tree::nodes 885# ---------------------------------------------------------------------------- 886proc Tree::nodes { path node {first ""} {last ""} } { 887 variable $path 888 upvar 0 $path data 889 890 set node [_node_name $path $node] 891 if { ![info exists data($node)] } { 892 return -code error "node \"$node\" does not exist" 893 } 894 895 if { ![string length $first] } { 896 return [lrange $data($node) 1 end] 897 } 898 899 if { ![string length $last] } { 900 return [lindex [lrange $data($node) 1 end] $first] 901 } else { 902 return [lrange [lrange $data($node) 1 end] $first $last] 903 } 904} 905 906 907# Tree::visiblenodes -- 908# 909# Retrieve a list of all the nodes in a tree. 910# 911# Arguments: 912# path tree to retrieve nodes for. 913# 914# Results: 915# nodes list of nodes in the tree. 916 917proc Tree::visiblenodes { path } { 918 variable $path 919 upvar 0 $path data 920 921 # Root is always open (?), so all of its children automatically get added 922 # to the result, and to the stack. 923 set st [lrange $data(root) 1 end] 924 set result $st 925 926 while {[llength $st]} { 927 set node [lindex $st end] 928 set st [lreplace $st end end] 929 # Danger, danger! Using getMegawidgetOption is fragile, but much 930 # much faster than going through cget. 931 if { [Widget::getMegawidgetOption $path.$node -open] } { 932 set nodes [lrange $data($node) 1 end] 933 set result [concat $result $nodes] 934 set st [concat $st $nodes] 935 } 936 } 937 return $result 938} 939 940# ---------------------------------------------------------------------------- 941# Command Tree::see 942# ---------------------------------------------------------------------------- 943proc Tree::see { path node } { 944 variable $path 945 upvar 0 $path data 946 947 set node [_node_name $path $node] 948 if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } { 949 after cancel $data(upd,afterid) 950 _redraw_tree $path 951 } 952 set idn [$path.c find withtag n:$node] 953 if { $idn != "" } { 954 Tree::_see $path $idn 955 } 956} 957 958 959# ---------------------------------------------------------------------------- 960# Command Tree::opentree 961# ---------------------------------------------------------------------------- 962# JDC: added option recursive 963proc Tree::opentree { path node {recursive 1} } { 964 variable $path 965 upvar 0 $path data 966 967 set node [_node_name $path $node] 968 if { [string equal $node "root"] || ![info exists data($node)] } { 969 return -code error "node \"$node\" does not exist" 970 } 971 972 _recexpand $path $node 1 $recursive [Widget::getoption $path -opencmd] 973 _redraw_idle $path 3 974} 975 976 977# ---------------------------------------------------------------------------- 978# Command Tree::closetree 979# ---------------------------------------------------------------------------- 980proc Tree::closetree { path node {recursive 1} } { 981 variable $path 982 upvar 0 $path data 983 984 set node [_node_name $path $node] 985 if { [string equal $node "root"] || ![info exists data($node)] } { 986 return -code error "node \"$node\" does not exist" 987 } 988 989 _recexpand $path $node 0 $recursive [Widget::getoption $path -closecmd] 990 _redraw_idle $path 3 991} 992 993 994proc Tree::toggle { path node } { 995 if {[$path itemcget $node -open]} { 996 $path closetree $node 0 997 } else { 998 $path opentree $node 0 999 } 1000} 1001 1002 1003# ---------------------------------------------------------------------------- 1004# Command Tree::edit 1005# ---------------------------------------------------------------------------- 1006proc Tree::edit { path node text {verifycmd ""} {clickres 0} {select 1}} { 1007 variable _edit 1008 variable $path 1009 upvar 0 $path data 1010 1011 set node [_node_name $path $node] 1012 if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } { 1013 after cancel $data(upd,afterid) 1014 _redraw_tree $path 1015 } 1016 set idn [$path.c find withtag n:$node] 1017 if { $idn != "" } { 1018 Tree::_see $path $idn 1019 1020 set oldfg [$path.c itemcget $idn -fill] 1021 set sbg [Widget::getoption $path -selectbackground] 1022 set coords [$path.c coords $idn] 1023 set x [lindex $coords 0] 1024 set y [lindex $coords 1] 1025 set bd [expr {[$path.c cget -borderwidth]+[$path.c cget -highlightthickness]}] 1026 set w [expr {[winfo width $path] - 2*$bd}] 1027 set wmax [expr {[$path.c canvasx $w]-$x}] 1028 1029 set _edit(text) $text 1030 set _edit(wait) 0 1031 1032 $path.c itemconfigure $idn -fill [Widget::getoption $path -background] 1033 $path.c itemconfigure s:$node -fill {} -outline {} 1034 1035 set frame [frame $path.edit \ 1036 -relief flat -borderwidth 0 -highlightthickness 0 \ 1037 -background [Widget::getoption $path -background]] 1038 set ent [entry $frame.edit \ 1039 -width 0 \ 1040 -relief solid \ 1041 -borderwidth 1 \ 1042 -highlightthickness 0 \ 1043 -foreground [Widget::getoption $path.$node -fill] \ 1044 -background [Widget::getoption $path -background] \ 1045 -selectforeground [Widget::getoption $path -selectforeground] \ 1046 -selectbackground $sbg \ 1047 -font [Widget::getoption $path.$node -font] \ 1048 -textvariable Tree::_edit(text)] 1049 pack $ent -ipadx 8 -anchor w 1050 1051 set idw [$path.c create window $x $y -window $frame -anchor w] 1052 trace variable Tree::_edit(text) w \ 1053 [list Tree::_update_edit_size $path $ent $idw $wmax] 1054 tkwait visibility $ent 1055 grab $frame 1056 BWidget::focus set $ent 1057 1058 _update_edit_size $path $ent $idw $wmax 1059 update 1060 if { $select } { 1061 $ent selection range 0 end 1062 $ent icursor end 1063 $ent xview end 1064 } 1065 1066 bindtags $ent [list $ent Entry] 1067 bind $ent <Escape> {set Tree::_edit(wait) 0} 1068 bind $ent <Return> {set Tree::_edit(wait) 1} 1069 if { $clickres == 0 || $clickres == 1 } { 1070 bind $frame <Button> [list set Tree::_edit(wait) $clickres] 1071 } 1072 1073 set ok 0 1074 while { !$ok } { 1075 tkwait variable Tree::_edit(wait) 1076 if { !$_edit(wait) || [llength $verifycmd]==0 || 1077 [uplevel \#0 $verifycmd [list $_edit(text)]] } { 1078 set ok 1 1079 } 1080 } 1081 1082 trace vdelete Tree::_edit(text) w \ 1083 [list Tree::_update_edit_size $path $ent $idw $wmax] 1084 grab release $frame 1085 BWidget::focus release $ent 1086 destroy $frame 1087 $path.c delete $idw 1088 $path.c itemconfigure $idn -fill $oldfg 1089 $path.c itemconfigure s:$node -fill $sbg -outline $sbg 1090 1091 if { $_edit(wait) } { 1092 return $_edit(text) 1093 } 1094 } 1095 return "" 1096} 1097 1098 1099# ---------------------------------------------------------------------------- 1100# Command Tree::xview 1101# ---------------------------------------------------------------------------- 1102proc Tree::xview { path args } { 1103 return [eval [linsert $args 0 $path.c xview]] 1104} 1105 1106 1107# ---------------------------------------------------------------------------- 1108# Command Tree::yview 1109# ---------------------------------------------------------------------------- 1110proc Tree::yview { path args } { 1111 return [eval [linsert $args 0 $path.c yview]] 1112} 1113 1114 1115# ---------------------------------------------------------------------------- 1116# Command Tree::_update_edit_size 1117# ---------------------------------------------------------------------------- 1118proc Tree::_update_edit_size { path entry idw wmax args } { 1119 set entw [winfo reqwidth $entry] 1120 if { $entw+8 >= $wmax } { 1121 $path.c itemconfigure $idw -width $wmax 1122 } else { 1123 $path.c itemconfigure $idw -width 0 1124 } 1125} 1126 1127 1128# ---------------------------------------------------------------------------- 1129# Command Tree::_see 1130# ---------------------------------------------------------------------------- 1131proc Tree::_see { path idn } { 1132 set bbox [$path.c bbox $idn] 1133 set scrl [$path.c cget -scrollregion] 1134 1135 set ymax [lindex $scrl 3] 1136 set dy [$path.c cget -yscrollincrement] 1137 set yv [$path yview] 1138 set yv0 [expr {round([lindex $yv 0]*$ymax/$dy)}] 1139 set yv1 [expr {round([lindex $yv 1]*$ymax/$dy)}] 1140 set y [expr {int([lindex [$path.c coords $idn] 1]/$dy)}] 1141 if { $y < $yv0 } { 1142 $path.c yview scroll [expr {$y-$yv0}] units 1143 } elseif { $y >= $yv1 } { 1144 $path.c yview scroll [expr {$y-$yv1+1}] units 1145 } 1146 1147 set xmax [lindex $scrl 2] 1148 set dx [$path.c cget -xscrollincrement] 1149 set xv [$path xview] 1150 set x0 [expr {int([lindex $bbox 0]/$dx)}] 1151 set xv0 [expr {round([lindex $xv 0]*$xmax/$dx)}] 1152 set xv1 [expr {round([lindex $xv 1]*$xmax/$dx)}] 1153 if { $x0 >= $xv1 || $x0 < $xv0 } { 1154 $path.c xview scroll [expr {$x0-$xv0}] units 1155 } 1156} 1157 1158 1159# ---------------------------------------------------------------------------- 1160# Command Tree::_recexpand 1161# ---------------------------------------------------------------------------- 1162# JDC : added option recursive 1163proc Tree::_recexpand { path node expand recursive cmd } { 1164 variable $path 1165 upvar 0 $path data 1166 1167 if { [Widget::getoption $path.$node -open] != $expand } { 1168 Widget::setoption $path.$node -open $expand 1169 if {[llength $cmd]} { 1170 uplevel \#0 $cmd [list $node] 1171 } 1172 } 1173 1174 if { $recursive } { 1175 foreach subnode [lrange $data($node) 1 end] { 1176 _recexpand $path $subnode $expand $recursive $cmd 1177 } 1178 } 1179} 1180 1181 1182# ---------------------------------------------------------------------------- 1183# Command Tree::_subdelete 1184# ---------------------------------------------------------------------------- 1185proc Tree::_subdelete { path lnodes } { 1186 variable $path 1187 upvar 0 $path data 1188 1189 set sel $data(selnodes) 1190 set selchanged 0 1191 1192 while { [llength $lnodes] } { 1193 set lsubnodes [list] 1194 foreach node $lnodes { 1195 foreach subnode [lrange $data($node) 1 end] { 1196 lappend lsubnodes $subnode 1197 } 1198 unset data($node) 1199 set idx [lsearch -exact $sel $node] 1200 if { $idx >= 0 } { 1201 set sel [lreplace $sel $idx $idx] 1202 incr selchanged 1203 } 1204 if { [set win [Widget::getoption $path.$node -window]] != "" } { 1205 destroy $win 1206 } 1207 Widget::destroy $path.$node 1208 } 1209 set lnodes $lsubnodes 1210 } 1211 1212 set data(selnodes) $sel 1213 # return number of sel items changes 1214 return $selchanged 1215} 1216 1217 1218# ---------------------------------------------------------------------------- 1219# Command Tree::_update_scrollregion 1220# ---------------------------------------------------------------------------- 1221proc Tree::_update_scrollregion { path } { 1222 set bd [expr {2*([$path.c cget -borderwidth]+[$path.c cget -highlightthickness])}] 1223 set w [expr {[winfo width $path] - $bd}] 1224 set h [expr {[winfo height $path] - $bd}] 1225 set xinc [$path.c cget -xscrollincrement] 1226 set yinc [$path.c cget -yscrollincrement] 1227 set bbox [$path.c bbox node] 1228 if { [llength $bbox] } { 1229 set xs [lindex $bbox 2] 1230 set ys [lindex $bbox 3] 1231 1232 if { $w < $xs } { 1233 set w [expr {int($xs)}] 1234 if { [set r [expr {$w % $xinc}]] } { 1235 set w [expr {$w+$xinc-$r}] 1236 } 1237 } 1238 if { $h < $ys } { 1239 set h [expr {int($ys)}] 1240 if { [set r [expr {$h % $yinc}]] } { 1241 set h [expr {$h+$yinc-$r}] 1242 } 1243 } 1244 } 1245 1246 $path.c configure -scrollregion [list 0 0 $w $h] 1247 1248 if {[Widget::getoption $path -selectfill]} { 1249 _redraw_selection $path 1250 } 1251} 1252 1253 1254# ---------------------------------------------------------------------------- 1255# Command Tree::_cross_event 1256# ---------------------------------------------------------------------------- 1257proc Tree::_cross_event { path } { 1258 variable $path 1259 upvar 0 $path data 1260 1261 set node [Tree::_get_node_name $path current 1] 1262 if { [Widget::getoption $path.$node -open] } { 1263 Tree::itemconfigure $path $node -open 0 1264 if {[llength [set cmd [Widget::getoption $path -closecmd]]]} { 1265 uplevel \#0 $cmd [list $node] 1266 } 1267 } else { 1268 Tree::itemconfigure $path $node -open 1 1269 if {[llength [set cmd [Widget::getoption $path -opencmd]]]} { 1270 uplevel \#0 $cmd [list $node] 1271 } 1272 } 1273} 1274 1275 1276proc Tree::_draw_cross { path node open x y } { 1277 set idc [$path.c find withtag c:$node] 1278 1279 if { $open } { 1280 set img [Widget::cget $path -crossopenimage] 1281 set bmp [Widget::cget $path -crossopenbitmap] 1282 } else { 1283 set img [Widget::cget $path -crosscloseimage] 1284 set bmp [Widget::cget $path -crossclosebitmap] 1285 } 1286 1287 ## If we already have a cross for this node, we just adjust the image. 1288 if {$idc != ""} { 1289 if {$img == ""} { 1290 $path.c itemconfigure $idc -bitmap $bmp 1291 } else { 1292 $path.c itemconfigure $idc -image $img 1293 } 1294 return 1295 } 1296 1297 ## Create a new image for the cross. If the user has specified an 1298 ## image, it overrides a bitmap. 1299 if {$img == ""} { 1300 $path.c create bitmap $x $y \ 1301 -bitmap $bmp \ 1302 -background [$path.c cget -background] \ 1303 -foreground [Widget::getoption $path -crossfill] \ 1304 -tags [list cross c:$node] -anchor c 1305 } else { 1306 $path.c create image $x $y \ 1307 -image $img \ 1308 -tags [list cross c:$node] -anchor c 1309 } 1310} 1311 1312 1313# ---------------------------------------------------------------------------- 1314# Command Tree::_draw_node 1315# ---------------------------------------------------------------------------- 1316proc Tree::_draw_node { path node x0 y0 deltax deltay padx showlines } { 1317 variable $path 1318 upvar 0 $path data 1319 1320 set x1 [expr {$x0+$deltax+5}] 1321 set y1 $y0 1322 if { $showlines } { 1323 $path.c create line $x0 $y0 $x1 $y0 \ 1324 -fill [Widget::getoption $path -linesfill] \ 1325 -stipple [Widget::getoption $path -linestipple] \ 1326 -tags line 1327 } 1328 $path.c create text [expr {$x1+$padx}] $y0 \ 1329 -text [Widget::getoption $path.$node -text] \ 1330 -fill [Widget::getoption $path.$node -fill] \ 1331 -font [Widget::getoption $path.$node -font] \ 1332 -anchor w \ 1333 -tags [Tree::_get_node_tags $path $node [list node n:$node]] 1334 set len [expr {[llength $data($node)] > 1}] 1335 set dc [Widget::getoption $path.$node -drawcross] 1336 set exp [Widget::getoption $path.$node -open] 1337 1338 if { $len && $exp } { 1339 set y1 [_draw_subnodes $path [lrange $data($node) 1 end] \ 1340 [expr {$x0+$deltax}] $y0 $deltax $deltay $padx $showlines] 1341 } 1342 1343 if {![string equal $dc "never"] 1344 && ($len || [string equal $dc "always"] || [string equal $dc "allways"])} { 1345 _draw_cross $path $node $exp $x0 $y0 1346 } 1347 1348 if { [set win [Widget::getoption $path.$node -window]] != "" } { 1349 set a [Widget::cget $path.$node -anchor] 1350 $path.c create window $x1 $y0 -window $win -anchor $a \ 1351 -tags [Tree::_get_node_tags $path $node [list win i:$node]] 1352 } elseif { [set img [Widget::getoption $path.$node -image]] != "" } { 1353 set a [Widget::cget $path.$node -anchor] 1354 $path.c create image $x1 $y0 -image $img -anchor $a \ 1355 -tags [Tree::_get_node_tags $path $node [list img i:$node]] 1356 } 1357 set box [$path.c bbox n:$node i:$node] 1358 set id [$path.c create rect 0 [lindex $box 1] \ 1359 [winfo screenwidth $path] [lindex $box 3] \ 1360 -tags [Tree::_get_node_tags $path $node [list box b:$node]] \ 1361 -fill {} -outline {}] 1362 $path.c lower $id 1363 1364 _set_help $path $node 1365 1366 return $y1 1367} 1368 1369 1370# ---------------------------------------------------------------------------- 1371# Command Tree::_draw_subnodes 1372# ---------------------------------------------------------------------------- 1373proc Tree::_draw_subnodes { path nodes x0 y0 deltax deltay padx showlines } { 1374 set y1 $y0 1375 foreach node $nodes { 1376 set padx [_get_node_padx $path $node] 1377 set deltax [_get_node_deltax $path $node] 1378 set yp $y1 1379 set y1 [_draw_node $path $node $x0 [expr {$y1+$deltay}] $deltax $deltay $padx $showlines] 1380 } 1381 # Only draw a line to the invisible root node above the tree widget when 1382 # there are multiple top nodes. 1383 set len [llength $nodes] 1384 if { $showlines && $len && !($y0 < 0 && $len < 2) } { 1385 set id [$path.c create line $x0 $y0 $x0 [expr {$yp+$deltay}] \ 1386 -fill [Widget::getoption $path -linesfill] \ 1387 -stipple [Widget::getoption $path -linestipple] \ 1388 -tags line] 1389 1390 $path.c lower $id 1391 } 1392 return $y1 1393} 1394 1395 1396# ---------------------------------------------------------------------------- 1397# Command Tree::_update_nodes 1398# ---------------------------------------------------------------------------- 1399proc Tree::_update_nodes { path } { 1400 variable $path 1401 upvar 0 $path data 1402 1403 foreach {node flag} $data(upd,nodes) { 1404 set idn [$path.c find withtag "n:$node"] 1405 if { $idn == "" } { 1406 continue 1407 } 1408 set padx [_get_node_padx $path $node] 1409 set deltax [_get_node_deltax $path $node] 1410 set c [$path.c coords $idn] 1411 set x1 [expr {[lindex $c 0]-$padx}] 1412 set x0 [expr {$x1-$deltax-5}] 1413 set y0 [lindex $c 1] 1414 if { $flag & 48 } { 1415 # -window or -image modified 1416 set win [Widget::getoption $path.$node -window] 1417 set img [Widget::getoption $path.$node -image] 1418 set anc [Widget::cget $path.$node -anchor] 1419 set idi [$path.c find withtag i:$node] 1420 set type [lindex [$path.c gettags $idi] 1] 1421 if { [string length $win] } { 1422 if { [string equal $type "win"] } { 1423 $path.c itemconfigure $idi -window $win 1424 } else { 1425 $path.c delete $idi 1426 $path.c create window $x1 $y0 -window $win -anchor $anc \ 1427 -tags [_get_node_tags $path $node [list win i:$node]] 1428 } 1429 } elseif { [string length $img] } { 1430 if { [string equal $type "img"] } { 1431 $path.c itemconfigure $idi -image $img 1432 } else { 1433 $path.c delete $idi 1434 $path.c create image $x1 $y0 -image $img -anchor $anc \ 1435 -tags [_get_node_tags $path $node [list img i:$node]] 1436 } 1437 } else { 1438 $path.c delete $idi 1439 } 1440 } 1441 1442 if { $flag & 8 } { 1443 # -drawcross modified 1444 set len [expr {[llength $data($node)] > 1}] 1445 set dc [Widget::getoption $path.$node -drawcross] 1446 set exp [Widget::getoption $path.$node -open] 1447 1448 if {![string equal $dc "never"] 1449 && ($len || [string equal $dc "always"] || [string equal $dc "allways"])} { 1450 _draw_cross $path $node $exp $x0 $y0 1451 } else { 1452 set idc [$path.c find withtag c:$node] 1453 $path.c delete $idc 1454 } 1455 } 1456 1457 if { $flag & 7 } { 1458 # -font, -text or -fill modified 1459 $path.c itemconfigure $idn \ 1460 -text [Widget::getoption $path.$node -text] \ 1461 -fill [Widget::getoption $path.$node -fill] \ 1462 -font [Widget::getoption $path.$node -font] 1463 } 1464 } 1465} 1466 1467 1468# ---------------------------------------------------------------------------- 1469# Command Tree::_draw_tree 1470# ---------------------------------------------------------------------------- 1471proc Tree::_draw_tree { path } { 1472 variable $path 1473 upvar 0 $path data 1474 1475 $path.c delete all 1476 set cursor [$path.c cget -cursor] 1477 $path.c configure -cursor watch 1478 _draw_subnodes $path [lrange $data(root) 1 end] 8 \ 1479 [expr {-[Widget::getoption $path -deltay]/2}] \ 1480 [Widget::getoption $path -deltax] \ 1481 [Widget::getoption $path -deltay] \ 1482 [Widget::getoption $path -padx] \ 1483 [Widget::getoption $path -showlines] 1484 $path.c configure -cursor $cursor 1485} 1486 1487 1488# ---------------------------------------------------------------------------- 1489# Command Tree::_redraw_tree 1490# ---------------------------------------------------------------------------- 1491proc Tree::_redraw_tree { path } { 1492 variable $path 1493 upvar 0 $path data 1494 1495 if { [Widget::getoption $path -redraw] } { 1496 if { $data(upd,level) == 2 } { 1497 _update_nodes $path 1498 } elseif { $data(upd,level) == 3 } { 1499 _draw_tree $path 1500 } 1501 _redraw_selection $path 1502 _update_scrollregion $path 1503 set data(upd,nodes) {} 1504 set data(upd,level) 0 1505 set data(upd,afterid) "" 1506 } 1507} 1508 1509 1510# ---------------------------------------------------------------------------- 1511# Command Tree::_redraw_selection 1512# ---------------------------------------------------------------------------- 1513proc Tree::_redraw_selection { path } { 1514 variable $path 1515 upvar 0 $path data 1516 1517 set selbg [Widget::getoption $path -selectbackground] 1518 set selfg [Widget::getoption $path -selectforeground] 1519 set fill [Widget::getoption $path -selectfill] 1520 if {$fill} { 1521 set scroll [$path.c cget -scrollregion] 1522 if {[llength $scroll]} { 1523 set xmax [expr {[lindex $scroll 2]-1}] 1524 } else { 1525 set xmax [winfo width $path] 1526 } 1527 } 1528 foreach id [$path.c find withtag sel] { 1529 set node [Tree::_get_node_name $path $id 1] 1530 $path.c itemconfigure "n:$node" -fill [Widget::getoption $path.$node -fill] 1531 } 1532 $path.c delete sel 1533 foreach node $data(selnodes) { 1534 set bbox [$path.c bbox "n:$node"] 1535 if { [llength $bbox] } { 1536 if {$fill} { 1537 # get the image to (if any), as it may have different height 1538 set bbox [$path.c bbox "n:$node" "i:$node"] 1539 set bbox [list 0 [lindex $bbox 1] $xmax [lindex $bbox 3]] 1540 } 1541 set id [$path.c create rectangle $bbox -tags [list sel s:$node] \ 1542 -fill $selbg -outline $selbg] 1543 if {$selfg != ""} { 1544 # Don't allow an empty fill - that would be transparent 1545 $path.c itemconfigure "n:$node" -fill $selfg 1546 } 1547 $path.c lower $id 1548 } 1549 } 1550} 1551 1552 1553# ---------------------------------------------------------------------------- 1554# Command Tree::_redraw_idle 1555# ---------------------------------------------------------------------------- 1556proc Tree::_redraw_idle { path level } { 1557 variable $path 1558 upvar 0 $path data 1559 1560 if { [Widget::getoption $path -redraw] && $data(upd,afterid) == "" } { 1561 set data(upd,afterid) [after idle [list Tree::_redraw_tree $path]] 1562 } 1563 if { $level > $data(upd,level) } { 1564 set data(upd,level) $level 1565 } 1566 return "" 1567} 1568 1569 1570# ---------------------------------------------------------------------------- 1571# Command Tree::_init_drag_cmd 1572# ---------------------------------------------------------------------------- 1573proc Tree::_init_drag_cmd { path X Y top } { 1574 set path [winfo parent $path] 1575 set ltags [$path.c gettags current] 1576 set item [lindex $ltags 1] 1577 if { [string equal $item "node"] || 1578 [string equal $item "img"] || 1579 [string equal $item "win"] } { 1580 set node [Tree::_get_node_name $path current 2] 1581 if {[llength [set cmd [Widget::getoption $path -draginitcmd]]]} { 1582 return [uplevel \#0 $cmd [list $path $node $top]] 1583 } 1584 if { [set type [Widget::getoption $path -dragtype]] == "" } { 1585 set type "TREE_NODE" 1586 } 1587 if { [set img [Widget::getoption $path.$node -image]] != "" } { 1588 pack [label $top.l -image $img -padx 0 -pady 0] 1589 } 1590 return [list $type {copy move link} $node] 1591 } 1592 return {} 1593} 1594 1595 1596# ---------------------------------------------------------------------------- 1597# Command Tree::_drop_cmd 1598# ---------------------------------------------------------------------------- 1599proc Tree::_drop_cmd { path source X Y op type dnddata } { 1600 set path [winfo parent $path] 1601 variable $path 1602 upvar 0 $path data 1603 1604 $path.c delete drop 1605 if { [string length $data(dnd,afterid)] } { 1606 after cancel $data(dnd,afterid) 1607 set data(dnd,afterid) "" 1608 } 1609 set data(dnd,scroll) "" 1610 if {[llength [set cmd [Widget::getoption $path -dropcmd]]]} { 1611 return [uplevel \#0 $cmd \ 1612 [list $path $source $data(dnd,node) $op $type $dnddata]] 1613 } 1614 return 0 1615} 1616 1617 1618# ---------------------------------------------------------------------------- 1619# Command Tree::_over_cmd 1620# ---------------------------------------------------------------------------- 1621proc Tree::_over_cmd { path source event X Y op type dnddata } { 1622 set path [winfo parent $path] 1623 variable $path 1624 upvar 0 $path data 1625 1626 if { [string equal $event "leave"] } { 1627 # we leave the window tree 1628 $path.c delete drop 1629 if { [string length $data(dnd,afterid)] } { 1630 after cancel $data(dnd,afterid) 1631 set data(dnd,afterid) "" 1632 } 1633 set data(dnd,scroll) "" 1634 return 0 1635 } 1636 1637 if { [string equal $event "enter"] } { 1638 # we enter the window tree - dnd data initialization 1639 set mode [Widget::getoption $path -dropovermode] 1640 set data(dnd,mode) 0 1641 foreach c {w p n} { 1642 set data(dnd,mode) [expr {($data(dnd,mode) << 1) | ([string first $c $mode] != -1)}] 1643 } 1644 set bbox [$path.c bbox all] 1645 if { [llength $bbox] } { 1646 set data(dnd,xs) [lindex $bbox 2] 1647 set data(dnd,empty) 0 1648 } else { 1649 set data(dnd,xs) 0 1650 set data(dnd,empty) 1 1651 } 1652 set data(dnd,node) {} 1653 } 1654 1655 set x [expr {$X-[winfo rootx $path]}] 1656 set y [expr {$Y-[winfo rooty $path]}] 1657 $path.c delete drop 1658 set data(dnd,node) {} 1659 1660 # test for auto-scroll unless mode is widget only 1661 if { $data(dnd,mode) != 4 && [_auto_scroll $path $x $y] != "" } { 1662 return 2 1663 } 1664 1665 if { $data(dnd,mode) & 4 } { 1666 # dropovermode includes widget 1667 set target [list widget] 1668 set vmode 4 1669 } else { 1670 set target [list ""] 1671 set vmode 0 1672 } 1673 if { ($data(dnd,mode) & 2) && $data(dnd,empty) } { 1674 # dropovermode includes position and tree is empty 1675 lappend target [list root 0] 1676 set vmode [expr {$vmode | 2}] 1677 } 1678 1679 set xc [$path.c canvasx $x] 1680 set xs $data(dnd,xs) 1681 if { $xc <= $xs } { 1682 set yc [$path.c canvasy $y] 1683 set dy [$path.c cget -yscrollincrement] 1684 set line [expr {int($yc/$dy)}] 1685 set xi 0 1686 set yi [expr {$line*$dy}] 1687 set ys [expr {$yi+$dy}] 1688 set found 0 1689 foreach id [$path.c find overlapping $xi $yi $xs $ys] { 1690 set ltags [$path.c gettags $id] 1691 set item [lindex $ltags 1] 1692 if { [string equal $item "node"] || 1693 [string equal $item "img"] || 1694 [string equal $item "win"] } { 1695 # item is the label or image/window of the node 1696 set node [Tree::_get_node_name $path $id 2] 1697 set found 1 1698 break 1699 } 1700 } 1701 if {$found} { 1702 set padx [_get_node_padx $path $node] 1703 set deltax [_get_node_deltax $path $node] 1704 set xi [expr {[lindex [$path.c coords n:$node] 0] - $padx - 1}] 1705 if { $data(dnd,mode) & 1 } { 1706 # dropovermode includes node 1707 lappend target $node 1708 set vmode [expr {$vmode | 1}] 1709 } else { 1710 lappend target "" 1711 } 1712 1713 if { $data(dnd,mode) & 2 } { 1714 # dropovermode includes position 1715 if { $yc >= $yi+$dy/2 } { 1716 # position is after $node 1717 if { [Widget::getoption $path.$node -open] && 1718 [llength $data($node)] > 1 } { 1719 # $node is open and have subnodes 1720 # drop position is 0 in children of $node 1721 set parent $node 1722 set index 0 1723 set xli [expr {$xi-5}] 1724 } else { 1725 # $node is not open and doesn't have subnodes 1726 # drop position is after $node in children of parent of $node 1727 set parent [lindex $data($node) 0] 1728 set index [lsearch -exact $data($parent) $node] 1729 set xli [expr {$xi - $deltax - 5}] 1730 } 1731 set yl $ys 1732 } else { 1733 # position is before $node 1734 # drop position is before $node in children of parent of $node 1735 set parent [lindex $data($node) 0] 1736 set index [expr {[lsearch -exact $data($parent) $node] - 1}] 1737 set xli [expr {$xi - $deltax - 5}] 1738 set yl $yi 1739 } 1740 lappend target [list $parent $index] 1741 set vmode [expr {$vmode | 2}] 1742 } else { 1743 lappend target {} 1744 } 1745 1746 if { ($vmode & 3) == 3 } { 1747 # result have both node and position 1748 # we compute what is the preferred method 1749 if { $yc-$yi <= 3 || $ys-$yc <= 3 } { 1750 lappend target "position" 1751 } else { 1752 lappend target "node" 1753 } 1754 } 1755 } 1756 } 1757 1758 if {$vmode && [llength [set cmd [Widget::getoption $path -dropovercmd]]]} { 1759 # user-defined dropover command 1760 set res [uplevel \#0 $cmd [list $path $source $target $op $type $dnddata]] 1761 set code [lindex $res 0] 1762 set newmode 0 1763 if { $code & 1 } { 1764 # update vmode 1765 set mode [lindex $res 1] 1766 if { ($vmode & 1) && [string equal $mode "node"] } { 1767 set newmode 1 1768 } elseif { ($vmode & 2) && [string equal $mode "position"] } { 1769 set newmode 2 1770 } elseif { ($vmode & 4) && [string equal $mode "widget"] } { 1771 set newmode 4 1772 } 1773 } 1774 set vmode $newmode 1775 } else { 1776 if { ($vmode & 3) == 3 } { 1777 # result have both item and position 1778 # we choose the preferred method 1779 if { [string equal [lindex $target 3] "position"] } { 1780 set vmode [expr {$vmode & ~1}] 1781 } else { 1782 set vmode [expr {$vmode & ~2}] 1783 } 1784 } 1785 1786 if { $data(dnd,mode) == 4 || $data(dnd,mode) == 0 } { 1787 # dropovermode is widget or empty - recall is not necessary 1788 set code 1 1789 } else { 1790 set code 3 1791 } 1792 } 1793 1794 if {!$data(dnd,empty)} { 1795 # draw dnd visual following vmode 1796 if { $vmode & 1 } { 1797 set data(dnd,node) [list "node" [lindex $target 1]] 1798 $path.c create rectangle $xi $yi $xs $ys -tags drop 1799 } elseif { $vmode & 2 } { 1800 set data(dnd,node) [concat "position" [lindex $target 2]] 1801 $path.c create line $xli [expr {$yl-$dy/2}] $xli $yl $xs $yl -tags drop 1802 } elseif { $vmode & 4 } { 1803 set data(dnd,node) [list "widget"] 1804 } else { 1805 set code [expr {$code & 2}] 1806 } 1807 } 1808 1809 if { $code & 1 } { 1810 DropSite::setcursor based_arrow_down 1811 } else { 1812 DropSite::setcursor dot 1813 } 1814 return $code 1815} 1816 1817 1818# ---------------------------------------------------------------------------- 1819# Command Tree::_auto_scroll 1820# ---------------------------------------------------------------------------- 1821proc Tree::_auto_scroll { path x y } { 1822 variable $path 1823 upvar 0 $path data 1824 1825 set xmax [winfo width $path] 1826 set ymax [winfo height $path] 1827 set scroll {} 1828 if { $y <= 6 } { 1829 if { [lindex [$path.c yview] 0] > 0 } { 1830 set scroll [list yview -1] 1831 DropSite::setcursor sb_up_arrow 1832 } 1833 } elseif { $y >= $ymax-6 } { 1834 if { [lindex [$path.c yview] 1] < 1 } { 1835 set scroll [list yview 1] 1836 DropSite::setcursor sb_down_arrow 1837 } 1838 } elseif { $x <= 6 } { 1839 if { [lindex [$path.c xview] 0] > 0 } { 1840 set scroll [list xview -1] 1841 DropSite::setcursor sb_left_arrow 1842 } 1843 } elseif { $x >= $xmax-6 } { 1844 if { [lindex [$path.c xview] 1] < 1 } { 1845 set scroll [list xview 1] 1846 DropSite::setcursor sb_right_arrow 1847 } 1848 } 1849 1850 if { [string length $data(dnd,afterid)] && ![string equal $data(dnd,scroll) $scroll] } { 1851 after cancel $data(dnd,afterid) 1852 set data(dnd,afterid) "" 1853 } 1854 1855 set data(dnd,scroll) $scroll 1856 if { [string length $scroll] && ![string length $data(dnd,afterid)] } { 1857 set data(dnd,afterid) [after 200 [list Tree::_scroll $path $scroll]] 1858 } 1859 return $data(dnd,afterid) 1860} 1861 1862 1863# ---------------------------------------------------------------------------- 1864# Command Tree::_scroll 1865# ---------------------------------------------------------------------------- 1866proc Tree::_scroll { path scroll } { 1867 variable $path 1868 upvar 0 $path data 1869 set cmd [lindex $scroll 0] 1870 set dir [lindex $scroll 1] 1871 if { ($dir == -1 && [lindex [$path.c $cmd] 0] > 0) || 1872 ($dir == 1 && [lindex [$path.c $cmd] 1] < 1) } { 1873 $path.c $cmd scroll $dir units 1874 set data(dnd,afterid) [after 50 [list Tree::_scroll $path $scroll]] 1875 } else { 1876 set data(dnd,afterid) "" 1877 DropSite::setcursor dot 1878 } 1879} 1880 1881# Tree::_keynav -- 1882# 1883# Handle navigational keypresses on the tree. 1884# 1885# Arguments: 1886# which tag indicating the direction of motion: 1887# up move to the node graphically above current 1888# down move to the node graphically below current 1889# left close current if open, else move to parent 1890# right open current if closed, else move to child 1891# open open current if closed, close current if open 1892# win name of the tree widget 1893# 1894# Results: 1895# None. 1896 1897proc Tree::_keynav {which win} { 1898 # check for an empty tree 1899 if {[$win nodes root] eq ""} { 1900 return 1901 } 1902 1903 # Keyboard navigation is riddled with special cases. In order to avoid 1904 # the complex logic, we will instead make a list of all the visible, 1905 # selectable nodes, then do a simple next or previous operation. 1906 1907 # One easy way to get all of the visible nodes is to query the canvas 1908 # object for all the items with the "node" tag; since the tree is always 1909 # completely redrawn, this list will be in vertical order. 1910 set nodes {} 1911 foreach nodeItem [$win.c find withtag node] { 1912 set node [Tree::_get_node_name $win $nodeItem 2] 1913 if { [Widget::cget $win.$node -selectable] } { 1914 lappend nodes $node 1915 } 1916 } 1917 1918 # Keyboard navigation is all relative to the current node 1919 # surles: Get the current node for single or multiple selection schemas. 1920 set node [_get_current_node $win] 1921 1922 switch -exact -- $which { 1923 "up" { 1924 # Up goes to the node that is vertically above the current node 1925 # (NOT necessarily the current node's parent) 1926 if { [string equal $node ""] } { 1927 return 1928 } 1929 set index [lsearch -exact $nodes $node] 1930 incr index -1 1931 if { $index >= 0 } { 1932 $win selection set [lindex $nodes $index] 1933 _set_current_node $win [lindex $nodes $index] 1934 $win see [lindex $nodes $index] 1935 event generate $win <<TreeSelect>> 1936 return 1937 } 1938 } 1939 "down" { 1940 # Down goes to the node that is vertically below the current node 1941 if { [string equal $node ""] } { 1942 $win selection set [lindex $nodes 0] 1943 _set_current_node $win [lindex $nodes 0] 1944 $win see [lindex $nodes 0] 1945 event generate $win <<TreeSelect>> 1946 return 1947 } 1948 1949 set index [lsearch -exact $nodes $node] 1950 incr index 1951 if { $index < [llength $nodes] } { 1952 $win selection set [lindex $nodes $index] 1953 _set_current_node $win [lindex $nodes $index] 1954 $win see [lindex $nodes $index] 1955 event generate $win <<TreeSelect>> 1956 return 1957 } 1958 } 1959 "right" { 1960 # On a right arrow, if the current node is closed, open it. 1961 # If the current node is open, go to its first child 1962 if { [string equal $node ""] } { 1963 return 1964 } 1965 set open [$win itemcget $node -open] 1966 if { $open } { 1967 if { [llength [$win nodes $node]] } { 1968 set index [lsearch -exact $nodes $node] 1969 incr index 1970 if { $index < [llength $nodes] } { 1971 $win selection set [lindex $nodes $index] 1972 _set_current_node $win [lindex $nodes $index] 1973 $win see [lindex $nodes $index] 1974 event generate $win <<TreeSelect>> 1975 return 1976 } 1977 } 1978 } else { 1979 $win itemconfigure $node -open 1 1980 if {[llength [set cmd [Widget::getoption $win -opencmd]]]} { 1981 uplevel \#0 $cmd [list $node] 1982 } 1983 return 1984 } 1985 } 1986 "left" { 1987 # On a left arrow, if the current node is open, close it. 1988 # If the current node is closed, go to its parent. 1989 if { [string equal $node ""] } { 1990 return 1991 } 1992 set open [$win itemcget $node -open] 1993 if { $open } { 1994 $win itemconfigure $node -open 0 1995 if {[llength [set cmd [Widget::getoption $win -closecmd]]]} { 1996 uplevel \#0 $cmd [list $node] 1997 } 1998 return 1999 } else { 2000 set parent [$win parent $node] 2001 if { [string equal $parent "root"] } { 2002 set parent $node 2003 } else { 2004 while { ![$win itemcget $parent -selectable] } { 2005 set parent [$win parent $parent] 2006 if { [string equal $parent "root"] } { 2007 set parent $node 2008 break 2009 } 2010 } 2011 } 2012 $win selection set $parent 2013 _set_current_node $win $parent 2014 $win see $parent 2015 event generate $win <<TreeSelect>> 2016 return 2017 } 2018 } 2019 "space" { 2020 if { [string equal $node ""] } { 2021 return 2022 } 2023 set open [$win itemcget $node -open] 2024 if { [llength [$win nodes $node]] } { 2025 2026 # Toggle the open status of the chosen node. 2027 2028 $win itemconfigure $node -open [expr {$open?0:1}] 2029 2030 if {$open} { 2031 # Node was open, is now closed. Call the close-cmd 2032 2033 if {[llength [set cmd [Widget::getoption $win -closecmd]]]} { 2034 uplevel \#0 $cmd [list $node] 2035 } 2036 } else { 2037 # Node was closed, is now open. Call the open-cmd 2038 2039 if {[llength [set cmd [Widget::getoption $win -opencmd]]]} { 2040 uplevel \#0 $cmd [list $node] 2041 } 2042 } 2043 } 2044 } 2045 } 2046 return 2047} 2048 2049# Tree::_get_current_node -- 2050# 2051# Get the current node for either single or multiple 2052# node selection trees. If the tree allows for 2053# multiple selection, return the cursor node. Otherwise, 2054# if there is a selection, return the first node in the 2055# list. If there is no selection, return the root node. 2056# 2057# arguments: 2058# win name of the tree widget 2059# 2060# Results: 2061# The current node. 2062 2063proc Tree::_get_current_node {win} { 2064 if {[info exists selectTree::selectCursor($win)]} { 2065 set result $selectTree::selectCursor($win) 2066 } elseif {[llength [set selList [$win selection get]]]} { 2067 set result [lindex $selList 0] 2068 } else { 2069 set result "" 2070 } 2071 return $result 2072} 2073 2074# Tree::_set_current_node -- 2075# 2076# Set the current node for either single or multiple 2077# node selection trees. 2078# 2079# arguments: 2080# win Name of the tree widget 2081# node The current node. 2082# 2083# Results: 2084# None. 2085 2086proc Tree::_set_current_node {win node} { 2087 if {[info exists selectTree::selectCursor($win)]} { 2088 set selectTree::selectCursor($win) $node 2089 } 2090 return 2091} 2092 2093# Tree::_get_node_name -- 2094# 2095# Given a canvas item, get the name of the tree node represented by that 2096# item. 2097# 2098# Arguments: 2099# path tree to query 2100# item Optional canvas item to examine; if omitted, 2101# defaults to "current" 2102# tagindex Optional tag index, since the n:nodename tag is not 2103# in the same spot for all canvas items. If omitted, 2104# defaults to "end-1", so it works with "current" item. 2105# 2106# Results: 2107# node name of the tree node. 2108 2109proc Tree::_get_node_name {path {item current} {tagindex end-1} {truename 0}} { 2110 set node [string range [lindex [$path.c gettags $item] $tagindex] 2 end] 2111 if {$truename} { 2112 return [_node_name_rev $path $node] 2113 } 2114 return $node 2115} 2116 2117# Tree::_get_node_padx -- 2118# 2119# Given a node in the tree, return it's padx value. If the value is 2120# less than 0, default to the padx of the entire tree. 2121# 2122# Arguments: 2123# path Tree to query 2124# node Node in the tree 2125# 2126# Results: 2127# padx The numeric padx value 2128proc Tree::_get_node_padx {path node} { 2129 set padx [Widget::getoption $path.$node -padx] 2130 if {$padx < 0} { set padx [Widget::getoption $path -padx] } 2131 return $padx 2132} 2133 2134# Tree::_get_node_deltax -- 2135# 2136# Given a node in the tree, return it's deltax value. If the value is 2137# less than 0, default to the deltax of the entire tree. 2138# 2139# Arguments: 2140# path Tree to query 2141# node Node in the tree 2142# 2143# Results: 2144# deltax The numeric deltax value 2145proc Tree::_get_node_deltax {path node} { 2146 set deltax [Widget::getoption $path.$node -deltax] 2147 if {$deltax < 0} { set deltax [Widget::getoption $path -deltax] } 2148 return $deltax 2149} 2150 2151 2152# Tree::_get_node_tags -- 2153# 2154# Given a node in the tree, return a list of tags to apply to its 2155# canvas item. 2156# 2157# Arguments: 2158# path Tree to query 2159# node Node in the tree 2160# tags A list of tags to add to the final list 2161# 2162# Results: 2163# list The list of tags to apply to the canvas item 2164proc Tree::_get_node_tags {path node {tags ""}} { 2165 eval [linsert $tags 0 lappend list TreeItemSentinal] 2166 if {[Widget::getoption $path.$node -helptext] == "" && 2167 [Widget::getoption $path.$node -helpcmd] == ""} { return $list } 2168 2169 switch -- [Widget::getoption $path.$node -helptype] { 2170 balloon { 2171 lappend list BwHelpBalloon 2172 } 2173 variable { 2174 lappend list BwHelpVariable 2175 } 2176 } 2177 return $list 2178} 2179 2180# Tree::_set_help -- 2181# 2182# Register dynamic help for a node in the tree. 2183# 2184# Arguments: 2185# path Tree to query 2186# node Node in the tree 2187# force Optional argument to force a reset of the help 2188# 2189# Results: 2190# none 2191proc Tree::_set_help { path node } { 2192 Widget::getVariable $path help 2193 2194 set item $path.$node 2195 set opts [list -helptype -helptext -helpvar -helpcmd] 2196 foreach {cty ctx cv cc} [eval [linsert $opts 0 Widget::hasChangedX $item]] break 2197 set text [Widget::getoption $item -helptext] 2198 set cmd [Widget::getoption $item -helpcmd] 2199 2200 ## If we've never set help for this item before, and text or cmd is not 2201 ## blank, we need to setup help. We also need to reset help if any of the 2202 ## options have changed. 2203 if { (![info exists help($node)] && ($text != "" || $cmd != "")) 2204 || $cty || $ctx || $cv } { 2205 set help($node) 1 2206 set type [Widget::getoption $item -helptype] 2207 set var [Widget::getoption $item -helpvar] 2208 DynamicHelp::add $path.c -item n:$node -type $type -text $text -variable $var -command $cmd 2209 DynamicHelp::add $path.c -item i:$node -type $type -text $text -variable $var -command $cmd 2210 DynamicHelp::add $path.c -item b:$node -type $type -text $text -variable $var -command $cmd 2211 } 2212} 2213 2214proc Tree::_mouse_select { path cmd args } { 2215 eval [linsert $args 0 selection $path $cmd] 2216 switch -- $cmd { 2217 "add" - "clear" - "remove" - "set" - "toggle" { 2218 event generate $path <<TreeSelect>> 2219 } 2220 } 2221} 2222 2223proc Tree::_node_name { path node } { 2224 # Make sure node names are safe as tags and variable names 2225 set map [list & \1 | \2 ^ \3 ! \4 :: \5] 2226 return [string map $map $node] 2227} 2228 2229proc Tree::_node_name_rev { path node } { 2230 # Allow reverse interpretation of node names 2231 set map [list \1 & \2 | \3 ^ \4 ! \5 ::] 2232 return [string map $map $node] 2233} 2234 2235 2236# ---------------------------------------------------------------------------- 2237# Command Tree::_destroy 2238# ---------------------------------------------------------------------------- 2239proc Tree::_destroy { path } { 2240 variable $path 2241 upvar 0 $path data 2242 2243 if { $data(upd,afterid) != "" } { 2244 after cancel $data(upd,afterid) 2245 } 2246 if { $data(dnd,afterid) != "" } { 2247 after cancel $data(dnd,afterid) 2248 } 2249 _subdelete $path [lrange $data(root) 1 end] 2250 Widget::destroy $path 2251 unset data 2252} 2253 2254 2255proc Tree::_getnodes {path {node "root"}} { 2256 set nodes [$path nodes $node] 2257 foreach node $nodes { 2258 set nodes [concat $nodes [_getnodes $path $node]] 2259 } 2260 return $nodes 2261} 2262 2263 2264# ---------------------------------------------------------------------------- 2265# Command Tree::_themechanged 2266# ---------------------------------------------------------------------------- 2267proc Tree::_themechanged { path } { 2268 2269 if { ![winfo exists $path] } { return } 2270 BWidget::set_themedefaults 2271 2272 $path configure \ 2273 -background $BWidget::colors(SystemWindow) \ 2274 -selectbackground $BWidget::colors(SystemHighlight) \ 2275 -selectforeground $BWidget::colors(SystemHighlightText) \ 2276 -linesfill $BWidget::colors(SystemWindowText) \ 2277 -crossfill $BWidget::colors(SystemWindowText) 2278 2279 # make sure, existing items appear in the same color as well: 2280 set res [$path nodes "root"] 2281 2282 # res(ult) might be either a string or a list... 2283 if {[llength $res] == 0 && [string length $res] > 0} { 2284 2285 foreach node [_getnodes $path $res] { 2286 $path itemconfigure $node \ 2287 -fill $BWidget::colors(SystemWindowText) 2288 } 2289 } elseif { [llength $res] > 0 } { 2290 2291 foreach n $res { 2292 foreach node [_getnodes $path $n] { 2293 $path itemconfigure $node \ 2294 -fill $BWidget::colors(SystemWindowText) 2295 } 2296 } 2297 } 2298 2299 _redraw_idle $path 3 2300} 2301