1## 2## Layout routines taken from oooold code, author unkown. 3## Copyright 1995-1998 Jeffrey Hobbs, jeff.hobbs@acm.org 4## 5## Last Update: 28 June 1997 6## 7package require Widget 2.0 8package provide Hierarchy 2.0 9 10##----------------------------------------------------------------------- 11## PROCEDURE(S) 12## hierarchy, hierarchy_dir, hierarchy_widget 13## 14## ARGUMENTS && DESCRIPTION 15## 16## hierarchy <window pathname> <options> 17## Implements a hierarchical listbox 18## hierarchy_dir <window pathname> <options> 19## Implements a hierarchical listbox using a directory view structure 20## for the default methods 21## hierarchy_widget <window pathname> <options> 22## Implements a hierarchical listbox using a widget view structure 23## for the default methods 24## 25## OPTIONS 26## (Any canvas option may be used with a hierarchy) 27## 28## -autoscrollbar TCL_BOOLEAN DEFAULT: 1 29## Determines whether scrollbars automagically pop-up or 30## are permanently there. 31## 32## -browsecmd procedure DEFAULT: noop 33## A command which the widget will execute when the node is expanded 34## to retrieve the children of a node. The widget and node path are 35## appended to the command as a list of node names which 36## form a path to the node from the root. Thus the first 37## element of this list will always be the root node. 38## 39## -command procedure DEFAULT: noop 40## A command which the widget will execute when the node is toggled. 41## The name of the widget, the node path, and whether the children of 42## the node are showing (0/1) is appended to the procedure args. 43## 44## -decoration TCL_BOOLEAN DEFAULT: 1 45## If this is true, the "tree" lines are drawn. 46## 47## -expand # DEFAULT: 1 48## an integer value for an initial depth to expand to. 49## 50## -font fontname DEFAULT: fixed 51## The default font used for the text. 52## 53## -foreground color DEFAULT: black 54## The default foreground color used for text of unselected nodes. 55## 56## -ipad # DEFAULT: 3 57## The internal space added between the image and the text for a 58## given node. 59## 60## -nodelook procedure DEFAULT: noop 61## A command the widget will execute to get the look of a node. 62## The node is appended to the command as a list of 63## node-names which form a path to the node from the root. 64## Thus the first element of this list will always be the 65## root node. Also appended is a 66## boolean value which indicates whether the node's children 67## are currently displayed. This allows the node's 68## look to change if it is "opened" or "closed". 69## 70## This command must return a 4-tuple list containing: 71## 0. the text to display at the node 72## 1. the font to use for the text 73## 2. an image to display 74## 3. the foreground color to use for the node 75## If no font (ie. {}) is specified then 76## the value from -font is used. If no image is specified 77## then no image is displayed. 78## The default is a command to which produces a nice look 79## for a file manager. 80## 81## -paddepth # DEFAULT: 12 82## The indent space added for child branches. 83## 84## -padstack # DEFAULT: 2 85## The space added between two rows 86## 87## -root rootname DEFAULT: {} 88## The name of the root node of the tree. Each node 89## name must be unique amongst the children of each node. 90## 91## -selectbackground color DEFAULT: red 92## The default background color used for the text of selected nodes. 93## 94## -selectmode (single|browse|multiple) DEFAULT: browse 95## Like listbox modes, "multiple" is a mix of multiple && extended. 96## 97## -showall TCL_BOOLEAN DEFAULT: 0 98## For directory nodelook, also show Unix '.' (hidden) files/dirs. 99## 100## -showfiles TCL_BOOLEAN DEFAULT: 0 101## Show files as well as directories. 102## 103## -showparent string DEFAULT: {} 104## For hierarchy_dir nodelook, if string != {}, then it will show that 105## string which will reset the root node to its parent. 106## 107## METHODS 108## These are the methods that the hierachical listbox object recognizes. 109## (ie - hierachy .h ; .h <method> <args>) 110## Any unique substring is acceptable 111## 112## configure ?option? ?value option value ...? 113## cget option 114## Standard tk widget routines. 115## 116## close index 117## Closes the specified index (will trigger -command). 118## 119## curselection 120## Returns the indices of the selected items. This differs from the 121## listbox method because indices here have no implied order. 122## 123## get index ?index ...? 124## Returns the node paths of the items referenced. Ranges are not 125## allowed. Index specification is like that allowed by the index 126## method. 127## 128## qget index ?index ...? 129## As above, but the indices must be that of the item (as returned 130## by the index or curselection method). 131## 132## index index 133## Returns the hierarchy numerical index of the item (the numerical 134## index has no implied order relative to the list items). index 135## may be of the form: 136## 137## number - Specifies the element as a numerical index. 138## root - specifies the root item. 139## string - Specifis an item that has that text in it's node. 140## @x,y - Indicates the element that covers the point in 141## the listbox window specified by x and y (in pixel 142## coordinates). If no element covers that point, 143## then the closest element to that point is used. 144## 145## open index 146## Opens the specified index (will trigger -command). 147## 148## see index 149## Ensures that the item specified by the index is viewable. 150## 151## refresh 152## Refreshes all open nodes 153## 154## selection option arg 155## This works like the listbox selection method with the following 156## exceptions: 157## 158## The selection clear option can take multiple indices, but not a range. 159## No arguments to clear means clear all the selected elements. 160## 161## The selection set option can take multiple indices, but not a range. 162## The key word 'all' sets the selection for all elements. 163## 164## size 165## Returns the number of items in the hierarchical listbox. 166## 167## toggle index 168## Toggles (open or closed) the item specified by index 169## (triggers -command). 170## 171## BINDINGS 172## Most Button-1 bindings on the hierarchy work in the same manner 173## as those for the listbox widget, as defined by the selectmode. 174## Those that vary are listed below: 175## 176## <Double-Button-1> 177## Toggles a node in the hierarchy 178## 179## NAMESPACE & STATE 180## The megawidget creates a global array with the classname, and a 181## global array which is the name of each megawidget is created. The latter 182## array is deleted when the megawidget is destroyed. 183## Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used. 184## Other procs that begin with $CLASSNAME are private. For each widget, 185## commands named .$widgetname and $CLASSNAME$widgetname are created. 186## 187##----------------------------------------------------------------------- 188 189# Create this to make sure there are registered in auto_mkindex 190# these must come before the [widget create ...] 191proc Hierarchy args {} 192proc hierarchy args {} 193 194## In general, we cannot use $data(basecmd) in the construction, but the 195## scrollbar commands won't be called until after it really exists as a 196## proper command 197widget create Hierarchy -type frame -base canvas -components { 198 {base canvas canvas {-relief sunken -bd 1 -highlightthickness 1 \ 199 -yscrollcommand [list $data(yscrollbar) set] \ 200 -xscrollcommand [list $data(xscrollbar) set]}} 201 {scrollbar xscrollbar sx {-orient h -bd 1 -highlightthickness 1\ 202 -command [list $data(basecmd) xview]}} 203 {scrollbar yscrollbar sy {-orient v -bd 1 -highlightthickness 1\ 204 -command [list $data(basecmd) yview]}} 205} -options { 206 {-autoscrollbar autoScrollbar AutoScrollbar 1} 207 {-browsecmd browseCmd BrowseCmd {}} 208 {-command command Command {}} 209 {-decoration decoration Decoration 1} 210 {-expand expand Expand 1} 211 {-font font Font fixed} 212 {-foreground foreground Foreground black} 213 {-ipad ipad Ipad 3} 214 {-nodelook nodeLook NodeLook {}} 215 {-paddepth padDepth PadDepth 12} 216 {-padstack padStack PadStack 2} 217 {-root root Root {}} 218 {-selectmode selectMode SelectMode browse} 219 {-selectbackground selectBackground SelectBackground red} 220 {-state state State normal} 221 222 {-showall showAll ShowAll 0} 223 {-showparent showParent ShowParent {}} 224 {-showfiles showFiles ShowFiles 0} 225} 226 227proc hierarchy_dir {w args} { 228 uplevel [list hierarchy $w -root [pwd] \ 229 -nodelook {namespace inscope ::Widget::Hierarchy FileLook} \ 230 -command {namespace inscope ::Widget::Hierarchy FileActivate} \ 231 -browsecmd {namespace inscope ::Widget::Hierarchy FileList}] \ 232 $args 233} 234 235proc hierarchy_widget {w args} { 236 uplevel [list hierarchy $w -root . \ 237 -nodelook {namespace inscope ::Widget::Hierarchy WidgetLook} \ 238 -command {namespace inscope ::Widget::Hierarchy WidgetActivate} \ 239 -browsecmd {namespace inscope ::Widget::Hierarchy WidgetList}] \ 240 $args 241} 242 243namespace eval ::Widget::Hierarchy {; 244 245;proc construct w { 246 upvar \#0 [namespace current]::$w data 247 248 ## Private variables 249 array set data [list \ 250 hasnodelook 0 \ 251 halfpstk [expr $data(-padstack)/2] \ 252 width 400 \ 253 ] 254 255 grid $data(canvas) $data(yscrollbar) -sticky news 256 grid $data(xscrollbar) -sticky ew 257 grid columnconfig $w 0 -weight 1 258 grid rowconfig $w 0 -weight 1 259 bind $data(canvas) <Configure> [namespace code [list Resize $w %w %h]] 260} 261 262;proc init w { 263 upvar \#0 [namespace current]::$w data 264 265 set data(:$data(-root),showkids) 0 266 ExpandNodeN $w $data(-root) $data(-expand) 267 if {[catch {$w see $data(-root)}]} { 268 $data(basecmd) configure -scrollregion {0 0 1 1} 269 } 270} 271 272;proc configure {w args} { 273 upvar \#0 [namespace current]::$w data 274 275 set truth {^(1|yes|true|on)$} 276 array set config { resize 0 root 0 showall 0 } 277 foreach {key val} $args { 278 switch -- $key { 279 -autoscrollbar { 280 set val [regexp -nocase $truth $val] 281 if {$val} { 282 set config(resize) 1 283 } else { 284 grid $data(xscrollbar) 285 grid $data(yscrollbar) 286 } 287 } 288 -decoration { set val [regexp -nocase $truth $val] } 289 -padstack { set data(halfpstk) [expr {$val/2}] } 290 -nodelook { 291 ## We set this special bool val because it saves some 292 ## computation in ExpandNode, a deeply nested proc 293 set data(hasnodelook) [string compare $val {}] 294 } 295 -root { 296 if {[info exists data(:$data(-root),showkids)]} { 297 ## All data about items and selection should be 298 ## cleared and the items deleted 299 foreach name [concat [array names data :*] \ 300 [array names data S,*]] {unset data($name)} 301 $data(basecmd) delete all 302 set data(-root) $val 303 set config(root) 1 304 ## Avoid setting data($key) below 305 continue 306 } 307 } 308 -selectbackground { 309 foreach i [array names data S,*] { 310 $data(basecmd) itemconfigure [string range $i 2 end] \ 311 -fill $val 312 } 313 } 314 -state { 315 if {![regexp {^(normal|disabled)$} $val junk val]} { 316 return -code error "bad state value \"$val\":\ 317 must be normal or disabled" 318 } 319 } 320 -showall - 321 -showfiles { 322 set val [regexp -nocase $truth $val] 323 if {$val == $data($key)} continue 324 set config(showall) 1 325 } 326 } 327 set data($key) $val 328 } 329 if {$config(root)} { 330 set data(:$val,showkids) 0 331 ExpandNodeN $w $val $data(-expand) 332 } elseif {$config(showall) && [info exists data(:$data(-root),showkids)]} { 333 _refresh $w 334 } elseif {$config(resize)} { 335 Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)] 336 } 337} 338 339## Cryptic source code arguments explained: 340## (these, or a similar form, might appear as variables later) 341## np == node path 342## cnp == changed np 343## knp == kids np 344## xcnp == extra cnp 345 346;proc _index { w idx } { 347 upvar \#0 [namespace current]::$w data 348 set c $data(basecmd) 349 if {[string match all $idx]} { 350 return [$c find withtag box] 351 } elseif {[regexp {^(root|anchor)$} $idx]} { 352 return [$c find withtag box:$data(-root)] 353 } 354 foreach i [$c find withtag $idx] { 355 if {[string match rec* [$c type $i]]} { return $i } 356 } 357 if {[regexp {@(-?[0-9]+),(-?[0-9]+)} $idx z x y]} { 358 return [$c find closest [$w canvasx $x] [$w canvasy $y] 1 text] 359 } 360 foreach i [$c find withtag box:[lindex $idx 0]] { return $i } 361 return -code error "bad hierarchy index \"$idx\":\ 362 must be current, @x,y, a number, or a node name" 363} 364 365;proc _selection { w args } { 366 if {[string match {} $args]} { 367 return -code error \ 368 "wrong \# args: should be \"$w selection option args\"" 369 } 370 upvar \#0 [namespace current]::$w data 371 set err [catch {_index $w [lindex $args 1]} idx] 372 switch -glob -- [lindex $args 0] { 373 an* { 374 ## anchor 375 ## stubbed out - too complicated to support 376 } 377 cl* { 378 ## clear 379 set c $data(basecmd) 380 if {$err} { 381 foreach arg [array names data S,*] { unset data($arg) } 382 $c itemconfig box -fill {} 383 } else { 384 catch {unset data(S,$idx)} 385 $c itemconfig $idx -fill {} 386 foreach idx [lrange $args 2 end] { 387 if {[catch {_index $w $idx} idx]} { 388 catch {unset data(S,$idx)} 389 $c itemconfig $idx -fill {} 390 } 391 } 392 } 393 } 394 in* { 395 ## includes 396 if {$err} { 397 if {[llength $args]==2} { 398 return -code error $idx 399 } else { 400 return -code error "wrong \# args:\ 401 should be \"$w selection includes index\"" 402 } 403 } 404 return [info exists data(S,$idx)] 405 } 406 se* { 407 ## set 408 if {$err} { 409 if {[string compare {} $args]} return 410 return -code error "wrong \# args:\ 411 should be \"$w selection set index ?index ...?\"" 412 } else { 413 set c $data(basecmd); set col $data(-selectbackground) 414 if {[string match all [lindex $args 1]]} { 415 foreach i $idx { set data(S,$i) 1 } 416 $c itemconfig box -fill $col 417 } else { 418 set data(S,$idx) 1 419 $c itemconfig $idx -fill $col 420 foreach idx [lrange $args 2 end] { 421 if {![catch {_index $w $idx} idx]} { 422 set data(S,$idx) 1 423 $c itemconfig $idx -fill $col 424 } 425 } 426 } 427 } 428 } 429 default { 430 return -code error "bad selection option \"[lindex $args 0]\":\ 431 must be clear, includes, set" 432 } 433 } 434} 435 436;proc _curselection {w} { 437 upvar \#0 [namespace current]::$w data 438 439 set res {} 440 foreach i [array names data S,*] { lappend res [string range $i 2 end] } 441 return $res 442} 443 444;proc _get {w args} { 445 upvar \#0 [namespace current]::$w data 446 447 set nps {} 448 foreach arg $args { 449 if {![catch {_index $w $arg} idx] && \ 450 [string compare {} $idx]} { 451 set tags [$data(basecmd) gettags $idx] 452 if {[set i [lsearch -glob $tags box:*]]>-1} { 453 lappend nps [string range [lindex $tags $i] 4 end] 454 } 455 } 456 } 457 return $nps 458} 459 460;proc _qget {w args} { 461 upvar \#0 [namespace current]::$w data 462 463 ## Quick get. Avoids expensive _index call 464 set nps {} 465 foreach arg $args { 466 set tags [$data(basecmd) itemcget $arg -tags] 467 if {[set i [lsearch -glob $tags box:*]]>-1} { 468 lappend nps [string range [lindex $tags $i] 4 end] 469 } 470 } 471 return $nps 472} 473 474;proc _see {w args} { 475 upvar \#0 [namespace current]::$w data 476 477 if {[catch {_index $w $args} idx]} { 478 return -code error $idx 479 } elseif {[string compare {} $idx]} { 480 set c $data(basecmd) 481 foreach {x y x1 y1} [$c bbox $idx] {top btm} [$c yview] { 482 set stk [lindex [$c cget -scrollregion] 3] 483 set pos [expr (($y1+$y)/2.0)/$stk - ($btm-$top)/2.0] 484 } 485 $c yview moveto $pos 486 } 487} 488 489;proc _refresh {w} { 490 upvar \#0 [namespace current]::$w data 491 492 array set expanded [array get data ":*,showkids"] 493 foreach i [concat [array names data :*] \ 494 [array names data S,*]] {unset data($i)} 495 $data(basecmd) delete all 496 ## -dec makes it sort in root-first order 497 foreach i [lsort -ascii -decreasing [array names expanded]] { 498 if {$expanded($i)} { 499 regexp {^:(.*),showkids$} $i junk np 500 ## Quick way to remove the last element of a list 501 set prnt [lreplace $np end end] 502 ## checks to get rid of dead, previously opened nodes 503 if {[string match {} $prnt] || ([info exists data(:$prnt,kids)] \ 504 && [lsearch -exact $data(:$prnt,kids) \ 505 [lindex $np end]] != -1)} { 506 set data($i) 0 507 ExpandNode $w $np 508 } 509 } 510 } 511 Redraw $w $data(-root) 512 Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)] 513} 514 515;proc _size {w} { 516 upvar \#0 [namespace current]::$w data 517 return [llength [$data(basecmd) find withtag box]] 518} 519 520## This will be the one called by <Double-Button-1> on the canvas, 521## if -state is normal, so we have to make sure that $w is correct. 522## 523;proc _toggle { w index } { 524 toggle $w $index toggle 525} 526 527;proc _close { w index } { 528 toggle $w $index close 529} 530 531;proc _open { w index } { 532 toggle $w $index open 533} 534 535;proc toggle { w index which } { 536 if {[string compare Hierarchy [winfo class $w]]} { 537 set w [winfo parent $w] 538 } 539 upvar \#0 [namespace current]::$w data 540 541 if {[string match {} [set np [_get $w $index]]]} return 542 set np [lindex $np 0] 543 544 set old [$data(basecmd) cget -cursor] 545 $data(basecmd) config -cursor watch 546 update 547 switch $which { 548 close { CollapseNodeAll $w $np } 549 open { ExpandNodeN $w $np 1 } 550 toggle { 551 if {$data(:$np,showkids)} { 552 CollapseNodeAll $w $np 553 } else { 554 ExpandNodeN $w $np 1 555 } 556 } 557 } 558 if {[string compare {} $data(-command)]} { 559 uplevel \#0 $data(-command) [list $w $np $data(:$np,showkids)] 560 } 561 $data(basecmd) config -cursor $old 562 return 563} 564 565;proc Resize { w wid hgt } { 566 upvar \#0 [namespace current]::$w data 567 set c $data(basecmd) 568 if {[string compare {} [set box [$c bbox image text]]]} { 569 set X [lindex $box 2] 570 if {$data(-autoscrollbar)} { 571 set Y [lindex $box 3] 572 if {$wid>$X} { 573 set X $wid 574 grid remove $data(xscrollbar) 575 } else { 576 grid $data(xscrollbar) 577 } 578 if {$hgt>$Y} { 579 set Y $hgt 580 grid remove $data(yscrollbar) 581 } else { 582 grid $data(yscrollbar) 583 } 584 $c config -scrollregion "0 0 $X $Y" 585 } 586 ## This makes full width highlight boxes 587 ## data(width) is the default width of boxes 588 if {$X>$data(width)} { 589 set data(width) $X 590 foreach b [$c find withtag box] { 591 foreach {x y x1 y1} [$c coords $b] { $c coords $b 0 $y $X $y1 } 592 } 593 } 594 } elseif {$data(-autoscrollbar)} { 595 grid remove $data(xscrollbar) $data(yscrollbar) 596 } 597} 598 599;proc CollapseNodeAll { w np } { 600 if {[CollapseNode $w $np]} { 601 upvar \#0 [namespace current]::$w data 602 Redraw $w $np 603 DiscardChildren $w $np 604 Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)] 605 } 606} 607 608;proc ExpandNodeN { w np n } { 609 upvar \#0 [namespace current]::$w data 610 if {[ExpandNodeN_aux $w $np $n] || \ 611 ([string compare $data(-root) {}] && \ 612 ![string compare $data(-root) $np])} { 613 Redraw $w $np 614 Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)] 615 } 616} 617 618;proc ExpandNodeN_aux { w np n } { 619 if {![ExpandNode $w $np]} { return 0 } 620 if {$n==1} { return 1 } 621 incr n -1 622 upvar \#0 [namespace current]::$w data 623 foreach k $data(:$np,kids) { 624 ExpandNodeN_aux $w "$np [list $k]" $n 625 } 626 return 1 627} 628 629######################################################################## 630## 631## Private routines to collapse and expand a single node w/o redrawing 632## Most routines return 0/1 to indicate if any change has occurred 633## 634######################################################################## 635 636;proc ExpandNode { w np } { 637 upvar \#0 [namespace current]::$w data 638 639 if {$data(:$np,showkids)} { return 0 } 640 set data(:$np,showkids) 1 641 if {![info exists data(:$np,kids)]} { 642 if {[string compare $data(-browsecmd) {}]} { 643 set data(:$np,kids) [uplevel \#0 $data(-browsecmd) [list $w $np]] 644 } else { 645 set data(:$np,kids) {} 646 } 647 } 648 if $data(hasnodelook) { 649 set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 1]] 650 } else { 651 set data(:$np,look) {} 652 } 653 if {[string match {} $data(:$np,kids)]} { 654 ## This is needed when there are no kids to make sure the 655 ## look of the node will be updated appropriately 656 foreach {txt font img fg} $data(:$np,look) { 657 lappend tags box:$np box $np 658 set c $data(basecmd) 659 if {[string compare $img {}]} { 660 ## Catch just in case the image doesn't exist 661 catch { 662 $c itemconfigure img:$np -image $img 663 lappend tags $img 664 } 665 } 666 if {[string compare $txt {}]} { 667 if {[string match {} $font]} { set font $data(-font) } 668 if {[string match {} $fg]} { set fg $data(-foreground) } 669 $c itemconfigure txt:$np -fill $fg -text $txt -font $font 670 if {[string compare $np $txt]} { lappend tags $txt } 671 } 672 $c itemconfigure box:$np -tags $tags 673 ## We only want to go through once 674 break 675 } 676 return 0 677 } 678 foreach k $data(:$np,kids) { 679 set knp "$np [list $k]" 680 ## Check to make sure it doesn't already exist, 681 ## in case we are refreshing the node or something 682 if {![info exists data(:$knp,showkids)]} { set data(:$knp,showkids) 0 } 683 if $data(hasnodelook) { 684 set data(:$knp,look) [uplevel \#0 $data(-nodelook) [list $w $knp 0]] 685 } else { 686 set data(:$knp,look) {} 687 } 688 } 689 return 1 690} 691 692;proc CollapseNode { w np } { 693 upvar \#0 [namespace current]::$w data 694 if {!$data(:$np,showkids)} { return 0 } 695 set data(:$np,showkids) 0 696 if {[string match {} $data(:$np,kids)]} { return 0 } 697 if {[string compare $data(-nodelook) {}]} { 698 set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 0]] 699 } else { 700 set data(:$np,look) {} 701 } 702 foreach k $data(:$np,kids) { CollapseNode $w "$np [list $k]" } 703 return 1 704} 705 706;proc DiscardChildren { w np } { 707 upvar \#0 [namespace current]::$w data 708 if {[info exists data(:$np,kids)]} { 709 foreach k $data(:$np,kids) { 710 set knp "$np [list $k]" 711 $data(basecmd) delete img:$knp txt:$knp box:$knp 712 foreach i {showkids look stkusg stack iwidth offset} { 713 catch {unset data(:$knp,$i)} 714 } 715 DiscardChildren $w $knp 716 } 717 unset data(:$np,kids) 718 } 719} 720 721## REDRAW mechanism 722## 2 parts: recompute offsets of all children from changed node path 723## then redraw children based on their offsets and look 724## 725;proc Redraw { w cnp } { 726 upvar \#0 [namespace current]::$w data 727 728 set c $data(basecmd) 729 # When a node changes, the positions of a whole lot of things 730 # change. The size of the scroll region also changes. 731 $c delete decor 732 733 # Calculate the new offset locations of everything 734 Recompute $w $data(-root) [lrange $cnp 1 end] 735 736 # Next recursively move all the bits around to their correct positions. 737 # We choose an initial point (4,4) to begin at. 738 Redraw_aux $w $data(-root) 4 4 739 740 # Necessary to make sure find closest gets the right item 741 # ordering: image > text > box 742 after idle "catch { [list $c] raise image text; [list $c] lower box text }" 743} 744 745## RECOMPUTE recurses through the tree working out the relative offsets 746## of children from their parents in terms of stack values. 747## 748## "cnp" is either empty or a node name which indicates where the only 749## changes have occured in the hierarchy since the last call to Recompute. 750## This is used because when a node is toggled on/off deep in the 751## hierarchy then not all the positions of items need to be recomputed. 752## The only ones that do are everything below the changed node (of 753## course), and also everything which might depend on the stack usage of 754## that node (i.e. everything above it). Specifically the usages of the 755## changed node's siblings do *not* need to be recomputed. 756## 757;proc Recompute { w np cnp } { 758 upvar \#0 [namespace current]::$w data 759 # If the cnp now has only one element then 760 # it must be one of the children of the current node. 761 # We do not need to Recompute the usages of its siblings if it is. 762 set cnode_is_child [expr {[llength $cnp]==1}] 763 if {$cnode_is_child} { 764 set cnode [lindex $cnp 0] 765 } else { 766 set xcnp [lrange $cnp 1 end] 767 } 768 769 # Run through the children, recursively calculating their usage of 770 # stack real-estate, and allocating an intial placement for each child 771 # 772 # Values do not need to be recomputed for siblings of the changed 773 # node and their descendants. For the cnode itself, in the 774 # recursive call we set the value of cnode to {} to prevent 775 # any further cnode checks. 776 777 set children_stack 0 778 if {$data(:$np,showkids)} { 779 foreach k $data(:$np,kids) { 780 set knp "$np [list $k]" 781 set data(:$knp,offset) $children_stack 782 if {$cnode_is_child && [string match $cnode $k]} { 783 set data(:$knp,stkusg) [Recompute $w $knp {}] 784 } elseif {!$cnode_is_child} { 785 set data(:$knp,stkusg) [Recompute $w $knp $xcnp] 786 } 787 incr children_stack $data(:$knp,stkusg) 788 incr children_stack $data(-padstack) 789 } 790 } 791 792 ## Make the image/text if they don't exist. 793 ## Positioning occurs in Redraw_aux. 794 ## And calculate the stack usage of our little piece of the world. 795 set img_height 0; set img_width 0; set txt_width 0; set txt_height 0 796 797 foreach {txt font img fg} $data(:$np,look) { 798 lappend tags box:$np box $np 799 set c $data(basecmd) 800 if {[string compare $img {}]} { 801 if {[string match {} [$c find withtag img:$np]]} { 802 $c create image 0 0 -anchor nw -tags [list img:$np image] 803 } 804 ## Catch just in case the image doesn't exist 805 catch { 806 $c itemconfigure img:$np -image $img 807 lappend tags $img 808 foreach {x y img_width img_height} [$c bbox img:$np] { 809 incr img_width -$x; incr img_height -$y 810 } 811 } 812 } 813 if {[string compare $txt {}]} { 814 if {[string match {} [$c find withtag txt:$np]]} { 815 $c create text 0 0 -anchor nw -tags [list txt:$np text] 816 } 817 if {[string match {} $font]} { set font $data(-font) } 818 if {[string match {} $fg]} { set fg $data(-foreground) } 819 $c itemconfigure txt:$np -fill $fg -text $txt -font $font 820 if {[string compare $np $txt]} { lappend tags $txt } 821 foreach {x y txt_width txt_height} [$c bbox txt:$np] { 822 incr txt_width -$x; incr txt_height -$y 823 } 824 } 825 if {[string match {} [$c find withtag box:$np]]} { 826 $c create rect 0 0 1 1 -tags [list box:$np box] -outline {} 827 } 828 $c itemconfigure box:$np -tags $tags 829 ## We only want to go through this once 830 break 831 } 832 833 set stack [expr {$txt_height>$img_height?$txt_height:$img_height}] 834 835 # Now reposition the children downward by "stack" 836 set overall_stack [expr {$children_stack+$stack}] 837 838 if {$data(:$np,showkids)} { 839 set off [expr {$stack+$data(-padstack)}] 840 foreach k $data(:$np,kids) { 841 set knp "$np [list $k]" 842 incr data(:$knp,offset) $off 843 } 844 } 845 # remember some facts for locating the image and drawing decor 846 array set data [list :$np,stack $stack :$np,iwidth $img_width] 847 848 return $overall_stack 849} 850 851;proc Redraw_aux {w np deppos stkpos} { 852 upvar \#0 [namespace current]::$w data 853 854 set c $data(basecmd) 855 $c coords img:$np $deppos $stkpos 856 $c coords txt:$np [expr {$deppos+$data(:$np,iwidth)+$data(-ipad)}] $stkpos 857 $c coords box:$np 0 [expr {$stkpos-$data(halfpstk)}] \ 858 $data(width) [expr {$stkpos+$data(:$np,stack)+$data(halfpstk)}] 859 860 if {!$data(:$np,showkids) || [string match {} $data(:$np,kids)]} return 861 862 set minkid_stkpos 100000 863 set maxkid_stkpos 0 864 set bar_deppos [expr {$deppos+$data(-paddepth)/2}] 865 set kid_deppos [expr {$deppos+$data(-paddepth)}] 866 867 foreach k $data(:$np,kids) { 868 set knp "$np [list $k]" 869 set kid_stkpos [expr {$stkpos+$data(:$knp,offset)}] 870 Redraw_aux $w $knp $kid_deppos $kid_stkpos 871 872 if {$data(-decoration)} { 873 if {$kid_stkpos<$minkid_stkpos} {set minkid_stkpos $kid_stkpos} 874 set kid_stkpos [expr {$kid_stkpos+$data(:$knp,stack)/2}] 875 if {$kid_stkpos>$maxkid_stkpos} {set maxkid_stkpos $kid_stkpos} 876 877 $c create line $bar_deppos $kid_stkpos $kid_deppos $kid_stkpos \ 878 -width 1 -tags decor 879 } 880 } 881 if {$data(-decoration)} { 882 $c create line $bar_deppos $minkid_stkpos $bar_deppos $maxkid_stkpos \ 883 -width 1 -tags decor 884 } 885} 886 887 888## 889## DEFAULT BINDINGS FOR HIERARCHY 890## 891## Since we give no border to the frame, all Hierarchy bindings 892## will always register on the canvas widget 893## 894bind Hierarchy <Double-Button-1> { 895 set w [winfo parent %W] 896 if {[string match normal [$w cget -state]]} { 897 $w toggle @%x,%y 898 } 899} 900bind Hierarchy <ButtonPress-1> { 901 if {[winfo exists %W]} { 902 namespace eval ::Widget::Hierarchy \ 903 [list BeginSelect [winfo parent %W] @%x,%y] 904 } 905} 906bind Hierarchy <B1-Motion> { 907 set tkPriv(x) %x 908 set tkPriv(y) %y 909 namespace eval ::Widget::Hierarchy [list Motion [winfo parent %W] @%x,%y] 910} 911bind Hierarchy <ButtonRelease-1> { tkCancelRepeat } 912bind Hierarchy <Shift-1> [namespace code \ 913 { BeginExtend [winfo parent %W] @%x,%y }] 914bind Hierarchy <Control-1> [namespace code \ 915 { BeginToggle [winfo parent %W] @%x,%y }] 916bind Hierarchy <B1-Leave> { 917 set tkPriv(x) %x 918 set tkPriv(y) %y 919 namespace eval ::Widget::Hierarchy [list AutoScan [winfo parent %W]] 920} 921bind Hierarchy <B1-Enter> { tkCancelRepeat } 922 923## Should reserve L/R U/D for traversing nodes 924bind Hierarchy <Up> { %W yview scroll -1 units } 925bind Hierarchy <Down> { %W yview scroll 1 units } 926bind Hierarchy <Left> { %W xview scroll -1 units } 927bind Hierarchy <Right> { %W xview scroll 1 units } 928 929bind Hierarchy <Control-Up> { %W yview scroll -1 pages } 930bind Hierarchy <Control-Down> { %W yview scroll 1 pages } 931bind Hierarchy <Control-Left> { %W xview scroll -1 pages } 932bind Hierarchy <Control-Right> { %W xview scroll 1 pages } 933bind Hierarchy <Prior> { %W yview scroll -1 pages } 934bind Hierarchy <Next> { %W yview scroll 1 pages } 935bind Hierarchy <Control-Prior> { %W xview scroll -1 pages } 936bind Hierarchy <Control-Next> { %W xview scroll 1 pages } 937bind Hierarchy <Home> { %W xview moveto 0 } 938bind Hierarchy <End> { %W xview moveto 1 } 939bind Hierarchy <Control-slash> [namespace code \ 940 { SelectAll [winfo parent %W] }] 941bind Hierarchy <Control-backslash> [namespace code \ 942 { [winfo parent %W] selection clear }] 943 944bind Hierarchy <2> { 945 set tkPriv(x) %x 946 set tkPriv(y) %y 947 %W scan mark %x %y 948} 949bind Hierarchy <B2-Motion> { 950 %W scan dragto $tkPriv(x) %y 951} 952 953## BINDING HELPER PROCEDURES 954## 955## These are mostly mirrored from the Listbox class bindings. 956## 957## Some of these are hacked up to be more efficient by making calls 958## that require forknowledge of the megawidget structure. 959## 960 961# BeginSelect -- 962# 963# This procedure is typically invoked on button-1 presses. It begins 964# the process of making a selection in the hierarchy. Its exact behavior 965# depends on the selection mode currently in effect for the hierarchy; 966# see the Motif documentation for details. 967# 968# Arguments: 969# w - The hierarchy widget. 970# el - The element for the selection operation (typically the 971# one under the pointer). Must be in numerical form. 972 973;proc BeginSelect {w el} { 974 global tkPriv 975 if {[catch {_index $w $el} el]} return 976 _selection $w clear 977 _selection $w set $el 978 set tkPriv(hierarchyPrev) $el 979} 980 981# Motion -- 982# 983# This procedure is called to process mouse motion events while 984# button 1 is down. It may move or extend the selection, depending 985# on the hierarchy's selection mode. 986# 987# Arguments: 988# w - The hierarchy widget. 989# el - The element under the pointer (must be a number). 990 991;proc Motion {w el} { 992 global tkPriv 993 if {[catch {_index $w $el} el] || \ 994 [string match $el $tkPriv(hierarchyPrev)]} return 995 switch [_cget $w -selectmode] { 996 browse { 997 _selection $w clear 0 end 998 if {![catch {_selection $w set $el}]} { 999 set tkPriv(hierarchyPrev) $el 1000 } 1001 } 1002 multiple { 1003 ## This happens when a double-1 occurs and all the index boxes 1004 ## have changed 1005 if {[catch {_selection $w includes \ 1006 $tkPriv(hierarchyPrev)} inc]} { 1007 set tkPriv(hierarchyPrev) [_index $w $el] 1008 return 1009 } 1010 if {$inc} { 1011 _selection $w set $el 1012 } else { 1013 _selection $w clear $el 1014 } 1015 set tkPriv(hierarchyPrev) $el 1016 } 1017 } 1018} 1019 1020# BeginExtend -- 1021# 1022# This procedure is typically invoked on shift-button-1 presses. It 1023# begins the process of extending a selection in the hierarchy. Its 1024# exact behavior depends on the selection mode currently in effect 1025# for the hierarchy; 1026# 1027# Arguments: 1028# w - The hierarchy widget. 1029# el - The element for the selection operation (typically the 1030# one under the pointer). Must be in numerical form. 1031 1032;proc BeginExtend {w el} { 1033 if {[catch {_index $w $el} el]} return 1034 if {[string match multiple [_cget $w -selectmode]]} { 1035 Motion $w $el 1036 } 1037} 1038 1039# BeginToggle -- 1040# 1041# This procedure is typically invoked on control-button-1 presses. It 1042# begins the process of toggling a selection in the hierarchy. Its 1043# exact behavior depends on the selection mode currently in effect 1044# for the hierarchy; see the Motif documentation for details. 1045# 1046# Arguments: 1047# w - The hierarchy widget. 1048# el - The element for the selection operation (typically the 1049# one under the pointer). Must be in numerical form. 1050 1051;proc BeginToggle {w el} { 1052 global tkPriv 1053 if {[catch {_index $w $el} el]} return 1054 if {[string match multiple [_cget $w -selectmode]]} { 1055 _selection $w anchor $el 1056 if {[_selection $w includes $el]} { 1057 _selection $w clear $el 1058 } else { 1059 _selection $w set $el 1060 } 1061 set tkPriv(hierarchyPrev) $el 1062 } 1063} 1064 1065# AutoScan -- 1066# This procedure is invoked when the mouse leaves an entry window 1067# with button 1 down. It scrolls the window up, down, left, or 1068# right, depending on where the mouse left the window, and reschedules 1069# itself as an "after" command so that the window continues to scroll until 1070# the mouse moves back into the window or the mouse button is released. 1071# 1072# Arguments: 1073# w - The hierarchy widget. 1074 1075;proc AutoScan {w} { 1076 global tkPriv 1077 if {![winfo exists $w]} return 1078 set x $tkPriv(x) 1079 set y $tkPriv(y) 1080 if {$y>=[winfo height $w]} { 1081 $w yview scroll 1 units 1082 } elseif {$y<0} { 1083 $w yview scroll -1 units 1084 } elseif {$x>=[winfo width $w]} { 1085 $w xview scroll 2 units 1086 } elseif {$x<0} { 1087 $w xview scroll -2 units 1088 } else { 1089 return 1090 } 1091 #Motion $w [$w index @$x,$y] 1092 set tkPriv(afterId) [after 50 [namespace current]::AutoScan $w] 1093} 1094 1095# SelectAll 1096# 1097# This procedure is invoked to handle the "select all" operation. 1098# For single and browse mode, it just selects the root element. 1099# Otherwise it selects everything in the widget. 1100# 1101# Arguments: 1102# w - The hierarchy widget. 1103 1104;proc SelectAll w { 1105 if {[regexp (browse|single) [_cget $w -selectmode]]} { 1106 _selection $w clear 1107 _selection $w set root 1108 } else { 1109 _selection $w set all 1110 } 1111} 1112 1113#------------------------------------------------------------ 1114# Default nodelook methods 1115#------------------------------------------------------------ 1116 1117;proc FileLook { w np isopen } { 1118 upvar \#0 [namespace current]::$w data 1119 set path [eval file join $np] 1120 set file [lindex $np end] 1121 set bmp {} 1122 if {[file readable $path]} { 1123 if {[file isdirectory $path]} { 1124 if {$isopen} { 1125 ## We know that kids will always be set by the time 1126 ## the isopen is set to 1 1127 if {[string compare $data(:$np,kids) {}]} { 1128 set bmp ::Widget::Hierarchy::bmp:dir_minus 1129 } else { 1130 set bmp ::Widget::Hierarchy::bmp:dir 1131 } 1132 } else { 1133 set bmp ::Widget::Hierarchy::bmp:dir_plus 1134 } 1135 if 0 { 1136 ## NOTE: accurate, but very expensive 1137 if {[string compare [FileList $w $np] {}]} { 1138 set bmp [expr {$isopen ?\ 1139 {::Widget::Hierarchy::bmp:dir_minus} :\ 1140 {::Widget::Hierarchy::bmp:dir_plus}}] 1141 } else { 1142 set bmp ::Widget::Hierarchy::bmp:dir 1143 } 1144 } 1145 } 1146 set fg \#000000 1147 } elseif {[string compare $data(-showparent) {}] && \ 1148 [string match $data(-showparent) $file]} { 1149 set fg \#0000FF 1150 set bmp ::Widget::Hierarchy::bmp:up 1151 } else { 1152 set fg \#a9a9a9 1153 if {[file isdirectory $path]} {set bmp ::Widget::Hierarchy::bmp:dir} 1154 } 1155 return [list $file $data(-font) $bmp $fg] 1156} 1157 1158## FileList 1159# ARGS: w hierarchy widget 1160# np node path 1161# Returns: directory listing 1162## 1163;proc FileList { w np } { 1164 set pwd [pwd] 1165 if {[catch "cd \[file join $np\]"]} { 1166 set list {} 1167 } else { 1168 global tcl_platform 1169 upvar \#0 [namespace current]::$w data 1170 set str * 1171 if {!$data(-showfiles)} { append str / } 1172 if {$data(-showall) && [string match unix $tcl_platform(platform)]} { 1173 ## NOTE: Use of non-core lremove 1174 if {[catch {lsort [concat [glob -nocomplain $str] \ 1175 [lremove [glob -nocomplain .$str] {. ..}]]} list]} { 1176 return {} 1177 } 1178 } else { 1179 ## The extra catch is necessary for unusual error conditions 1180 if {[catch {lsort [glob -nocomplain $str]} list]} { 1181 return {} 1182 } 1183 } 1184 set root $data(-root) 1185 if {[string compare {} $data(-showparent)] && \ 1186 [string match $root $np]} { 1187 if {![regexp {^(.:)?/+$} $root] && \ 1188 [string compare [file dir $root] $root]} { 1189 set list [linsert $list 0 $data(-showparent)] 1190 } 1191 } 1192 } 1193 cd $pwd 1194 return $list 1195} 1196 1197;proc FileActivate { w np isopen } { 1198 upvar \#0 [namespace current]::$w data 1199 set path [eval file join $np] 1200 if {[file isdirectory $path]} return 1201 if {[string compare $data(-showparent) {}] && \ 1202 [string match $data(-showparent) [lindex $np end]]} { 1203 $w configure -root [file dir $data(-root)] 1204 } 1205} 1206 1207;proc WidgetLook { W np isopen } { 1208 upvar \#0 [namespace current]::$W data 1209 if {$data(-showall)} { 1210 set w [lindex $np end] 1211 } else { 1212 set w [join $np {}] 1213 regsub {\.\.} $w {.} w 1214 } 1215 if {[string compare [winfo children $w] {}]} {set fg blue} {set fg black} 1216 return [list "\[[winfo class $w]\] [lindex $np end]" {} {} $fg] 1217} 1218 1219;proc WidgetList { W np } { 1220 upvar \#0 [namespace current]::$W data 1221 if {$data(-showall)} { 1222 set w [lindex $np end] 1223 } else { 1224 set w [join $np {}] 1225 regsub {\.\.} $w {.} w 1226 } 1227 set kids {} 1228 foreach i [lsort [winfo children $w]] { 1229 if {$data(-showall)} { 1230 lappend kids $i 1231 } else { 1232 lappend kids [file extension $i] 1233 } 1234 } 1235 return $kids 1236} 1237 1238;proc WidgetActivate { w np isopen } {} 1239 1240 1241## BITMAPS 1242## 1243image create bitmap ::Widget::Hierarchy::bmp:dir -data {#define folder_width 16 1244#define folder_height 12 1245static char folder_bits[] = { 1246 0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40, 1247 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};} 1248image create bitmap ::Widget::Hierarchy::bmp:dir_plus -data {#define folder_plus_width 16 1249 #define folder_plus_height 12 1250static char folder_plus_bits[] = { 1251 0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x82, 0x40, 1252 0x82, 0x40, 0xe2, 0x43, 0x82, 0x40, 0x82, 0x40, 0x02, 0x40, 0xfe, 0x7f};} 1253image create bitmap ::Widget::Hierarchy::bmp:dir_minus -data {#define folder_minus_width 16 1254#define folder_minus_height 12 1255static char folder_minus_bits[] = { 1256 0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40, 1257 0x02, 0x40, 0xe2, 0x43, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};} 1258image create bitmap ::Widget::Hierarchy::bmp:up -data {#define up.xbm_width 16 1259#define up.xbm_height 12 1260static unsigned char up.xbm_bits[] = { 1261 0x00, 0x00, 0x10, 0x00, 0x38, 0x00, 0x7c, 0x00, 0xfe, 0x00, 0x38, 0x00, 1262 0x38, 0x00, 0x38, 0x00, 0xf8, 0x7f, 0xf0, 0x7f, 0xe0, 0x7f, 0x00, 0x00};} 1263image create bitmap ::Widget::Hierarchy::bmp:text -data {#define text_width 15 1264#define text_height 14 1265static char text_bits[] = { 1266 0xff,0x07,0x01,0x0c,0x01,0x04,0x01,0x24,0xf9,0x7d,0x01,0x78,0x01,0x40,0xf1, 1267 0x41,0x01,0x40,0x01,0x40,0xf1,0x41,0x01,0x40,0x01,0x40,0xff,0x7f};} 1268 1269}; # end namespace ::Widget::Hierarchy 1270 1271return 1272