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## 7## Modified by Kish Shen Nov-Dec, 1998: 8## Fixed bug with selecting items with text that conflicts with item types 9## Added method to return index when given path 10## Added new procedure to be called when selection is made 11## Jan 1999: 12## modified the see method so that it display an item is visible in both its 13## x and y views, and not just the yview. 14## June 1999: 15## make sure that when scrolling in the y direction, the viewable part of the 16## x direction will adjust to ensure that items are visible. 17## added expandbranch method. 18 19package require Widget 2.0 20package provide Hierarchy 2.1 ;# updated version number 21 22##----------------------------------------------------------------------- 23## PROCEDURE(S) 24## hierarchy, hierarchy_dir, hierarchy_widget 25## 26## ARGUMENTS && DESCRIPTION 27## 28## hierarchy <window pathname> <options> 29## Implements a hierarchical listbox 30## hierarchy_dir <window pathname> <options> 31## Implements a hierarchical listbox using a directory view structure 32## for the default methods 33## hierarchy_widget <window pathname> <options> 34## Implements a hierarchical listbox using a widget view structure 35## for the default methods 36## 37## OPTIONS 38## (Any canvas option may be used with a hierarchy) 39## 40## -autoscrollbar TCL_BOOLEAN DEFAULT: 1 41## Determines whether scrollbars automagically pop-up or 42## are permanently there. 43## 44## -browsecmd procedure DEFAULT: noop 45## A command which the widget will execute when the node is expanded 46## to retrieve the children of a node. The widget and node path are 47## appended to the command as a list of node names which 48## form a path to the node from the root. Thus the first 49## element of this list will always be the root node. 50## 51## -command procedure DEFAULT: noop 52## A command which the widget will execute when the node is toggled. 53## The name of the widget, the node path, and whether the children of 54## the node are showing (0/1) is appended to the procedure args. 55## 56## -decoration TCL_BOOLEAN DEFAULT: 1 57## If this is true, the "tree" lines are drawn. 58## 59## -expand # DEFAULT: 1 60## an integer value for an initial depth to expand to. 61## 62## -font fontname DEFAULT: fixed 63## The default font used for the text. 64## 65## -foreground color DEFAULT: black 66## The default foreground color used for text of unselected nodes. 67## 68## -ipad # DEFAULT: 3 69## The internal space added between the image and the text for a 70## given node. 71## 72## -nodelook procedure DEFAULT: noop 73## A command the widget will execute to get the look of a node. 74## The node is appended to the command as a list of 75## node-names which form a path to the node from the root. 76## Thus the first element of this list will always be the 77## root node. Also appended is a 78## boolean value which indicates whether the node's children 79## are currently displayed. This allows the node's 80## look to change if it is "opened" or "closed". 81## 82## This command must return a 4-tuple list containing: 83## 0. the text to display at the node 84## 1. the font to use for the text 85## 2. an image to display 86## 3. the foreground color to use for the node 87## If no font (ie. {}) is specified then 88## the value from -font is used. If no image is specified 89## then no image is displayed. 90## The default is a command to which produces a nice look 91## for a file manager. 92## 93## -selectcmd procedure DEFAULT: noop 94## (added by Kish Shen, 1 Dec. 98) 95## A command the widget will execute when a node is selected by 96## clicking on it. The arguments for this command are: 97## widget index selected 98## where widget is the hierarchy widget name, index is the index of 99## the newly selected node, and selected is the list of indecies of 100## the previously selected node(s) *before* the current selection. 101## The procedure is called *after* the new selection is highlighted. 102## 103## 104## -paddepth # DEFAULT: 12 105## The indent space added for child branches. 106## 107## -padstack # DEFAULT: 2 108## The space added between two rows 109## 110## -root rootname DEFAULT: {} 111## The name of the root node of the tree. Each node 112## name must be unique amongst the children of each node. 113## 114## -selectbackground color DEFAULT: red 115## The default background color used for the text of selected nodes. 116## 117## -selectmode (single|browse|multiple) DEFAULT: browse 118## Like listbox modes, "multiple" is a mix of multiple && extended. 119## 120## -showall TCL_BOOLEAN DEFAULT: 0 121## For directory nodelook, also show Unix '.' (hidden) files/dirs. 122## 123## -showfiles TCL_BOOLEAN DEFAULT: 0 124## Show files as well as directories. 125## 126## -showparent string DEFAULT: {} 127## For hierarchy_dir nodelook, if string != {}, then it will show that 128## string which will reset the root node to its parent. 129## 130## METHODS 131## These are the methods that the hierachical listbox object recognizes. 132## (ie - hierachy .h ; .h <method> <args>) 133## Any unique substring is acceptable 134## 135## configure ?option? ?value option value ...? 136## cget option 137## Standard tk widget routines. 138## 139## close index 140## Closes the specified index (will trigger -command). 141## 142## curselection 143## Returns the indices of the selected items. This differs from the 144## listbox method because indices here have no implied order. 145## 146## get index ?index ...? 147## Returns the node paths of the items referenced. Ranges are not 148## allowed. Index specification is like that allowed by the index 149## method. 150## 151## qget index ?index ...? 152## As above, but the indices must be that of the item (as returned 153## by the index or curselection method). 154## 155## index index 156## Returns the hierarchy numerical index of the item (the numerical 157## index has no implied order relative to the list items). index 158## may be of the form: 159## 160## number - Specifies the element as a numerical index. 161## root - specifies the root item. 162## string - Specifis an item that has that text in it's node. 163## @x,y - Indicates the element that covers the point in 164## the listbox window specified by x and y (in pixel 165## coordinates). If no element covers that point, 166## then the closest element to that point is used. 167## 168## index np 169## Returns the hierarchy numerical index of an item when given the 170## node path of the item. 171## 172## 173## open index 174## Opens the specified index (will trigger -command). 175## 176## see index 177## Ensures that the item specified by the index is viewable. 178## 179## refresh 180## Refreshes all open nodes 181## 182## selection option arg 183## This works like the listbox selection method with the following 184## exceptions: 185## 186## The selection clear option can take multiple indices, but not a range. 187## No arguments to clear means clear all the selected elements. 188## 189## The selection set option can take multiple indices, but not a range. 190## The key word 'all' sets the selection for all elements. 191## 192## size 193## Returns the number of items in the hierarchical listbox. 194## 195## toggle index 196## Toggles (open or closed) the item specified by index 197## (triggers -command). 198## 199## Added by Kish Shen: 200## indexnp np 201## Returns the index of an item with the path name np, in hierarchy w 202## 203## isopen np 204## Returns 1 or 0 depending on if item with path name np in hierarchy w 205## is open or not. 206## 207## centreitem idx xmin xmax ymin ymax 208## Moves the visible part of the hierarchical display so that item idex 209## is displayed at its centre if possible. The other arguments are the 210## tolerances for when the display will be moved if the item is already 211## visible in the display (if not, the display is always moved). They 212## are all fractions of the visible display: 0.0 is at the first (left 213## or top edge) and 1.0 is the second (right or bottom) edge. For example, 214## 0.1 0.9 0.0 1.0 will mean that if the item was originally displayed 215## within 10% of the left and right edges of the view port, it will be 216## centred, and it will always be centred in the y direction. 217## 218## yfollowitem lefttol righttol toptol bottol 219## Turns on the yscroll-follow-item mode for the yscrollbar if it is not 220## on (the default is on). In this mode, when the yscrollbar is moved, 221## the `leading' item will always be visible, with the visible X portion 222## of the display adjusted if necessary. For moving up, the leading item 223## is the item that is toptol from the topedge of the display; for 224## moving down, the leading item is the item that is bottol from the 225## bottom edge of the display. If the leftside of the text in the leading 226## item will fall outside lefttol from the left edge and righttol from 227## the right edge of the display, the visible X portion of the display 228## will be adjusted so that the leftside of the text in the leading 229## item is at the middle. lefttol and righttol are fractions of the 230## display width, and toptol, bottol are fractions of the display height 231## The defaults are: 0.1 0.2 0.1 0.1 232## 233## ynofollowitem 234## Turns off the default yscroll-follow-item mode for yscrollbar. That 235## is, moving the yscrollbars will not affect the positioning of the X 236## portion of the display. 237## 238## yfollowstate 239## Returns the yscroll-follow-item mode state, in a list in the form 240## {yfollow left-tol right-tol top-tol bottom-tol} where yfollow is 241## a boolean indicating if the yscroll-follow-item mode is active or 242## not, and the others are the fractional tolerances as described above. 243## 244## expandbranch np0 m n aux 245## Expands one branch of the displayed tree by n levels by expanding the 246## mth child (counting from 1) at each level. The starting node has node 247## path np0, and should be a currently displayed node. After each level, 248## the user supplied procedure aux can be called: aux is either {} (no 249## calls) or is a list of the form {procname arglist} where arglist is a 250## list of extra arguments supplied by the user. The procedure would be 251## called as: 252## procname n np arglist 253## where n is the number of remaining levels to traverse, np is the node 254## path of the node that has just been expanded. The idea is that since 255## the expansion can take some time, this allows the user to provide some 256## feedback during the expansion. 257## The hierarchical display is not updated until the expansion is 258## complete. The procedure returns a list of the form 259## {status n np} 260## where status is 1 if the expansion is completed successfully, and 0 261## if not. n is the number of remaining levels if the expansion was not 262## completed successfully. np is the node path of the node reached after 263## the expansion. 264## 265## BINDINGS 266## Most Button-1 bindings on the hierarchy work in the same manner 267## as those for the listbox widget, as defined by the selectmode. 268## Those that vary are listed below: 269## 270## <Double-Button-1> 271## Toggles a node in the hierarchy 272## 273## NAMESPACE & STATE 274## The megawidget creates a global array with the classname, and a 275## global array which is the name of each megawidget is created. The latter 276## array is deleted when the megawidget is destroyed. 277## Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used. 278## Other procs that begin with $CLASSNAME are private. For each widget, 279## commands named .$widgetname and $CLASSNAME$widgetname are created. 280## 281##----------------------------------------------------------------------- 282 283# Create this to make sure there are registered in auto_mkindex 284# these must come before the [widget create ...] 285proc Hierarchy args {} 286proc hierarchy args {} 287 288## In general, we cannot use $data(basecmd) in the construction, but the 289## scrollbar commands won't be called until after it really exists as a 290## proper command 291widget create Hierarchy -type frame -base canvas -components { 292 {base canvas canvas {-relief sunken -bd 1 -highlightthickness 1 \ 293 -yscrollcommand [list $data(yscrollbar) set] \ 294 -xscrollcommand [list $data(xscrollbar) set]}} 295 {scrollbar xscrollbar sx {-orient h -bd 1 -highlightthickness 1\ 296 -command [list $data(basecmd) xview]}} 297 {scrollbar yscrollbar sy {-orient v -bd 1 -highlightthickness 1\ 298 -command [list hier_yscroll $data(widget_name) $data(basecmd)]}} 299} -options { 300 {-autoscrollbar autoScrollbar AutoScrollbar 1} 301 {-browsecmd browseCmd BrowseCmd {}} 302 {-command command Command {}} 303 {-decoration decoration Decoration 1} 304 {-expand expand Expand 1} 305 {-font font Font fixed} 306 {-foreground foreground Foreground black} 307 {-ipad ipad Ipad 3} 308 {-nodelook nodeLook NodeLook {}} 309 {-selectcmd selectCmd SelectCmd {}} 310 {-paddepth padDepth PadDepth 12} 311 {-padstack padStack PadStack 2} 312 {-root root Root {}} 313 {-selectmode selectMode SelectMode browse} 314 {-selectbackground selectBackground SelectBackground red} 315 {-state state State normal} 316 317 {-showall showAll ShowAll 0} 318 {-showparent showParent ShowParent {}} 319 {-showfiles showFiles ShowFiles 0} 320} 321 322;# TIP #44: to use tkCancelRepeat, a private Tk command in 8.4 323if {![llength [info commands tkCancelRepeat]]} { 324 tk::unsupported::ExposePrivateCommand tkCancelRepeat 325} 326 327;# called when hierarchy's yscrollbar is manipulated. 328proc hier_yscroll {w can args} { 329 330 331 foreach {yfollow ltol rtol ttol btol} [$w yfollowstate] {break} 332 if {$yfollow} { 333 ;# *0 are original values 334 foreach {ys0 ye0} [$can yview] {break} 335 set cmd [lindex $args 0] 336 switch -- $cmd { 337 moveto { 338 set ys [lindex $args 1] ;# ys is new top of screen 339 if {$ys < $ys0} { 340 set dir -1 341 } else { 342 set dir 1 343 } 344 } 345 scroll { 346 set dir [lindex $args 1] 347 } 348 default { 349 puts "unknown command - yview $args" 350 return -code error "unknown scroll option" 351 } 352 } 353 354 eval {$can yview} $args 355 foreach {xs xe} [$can xview] {break} 356 foreach {ys ye} [$can yview] {break} 357 foreach {left top right bottom} [$can cget -scrollregion] {break} 358 if {$dir > 0} { 359 set yetol [expr ($ye-$ys)*($bottom-$top)*$btol] 360 set yedge [expr round(($ye * ($bottom - $top)) + $top - $yetol)] 361 ;# yedge is new near-bottom edge in this case (moving down) 362 } else { 363 set yetol [expr ($ye-$ys)*($bottom-$top)*$ttol] 364 set yedge [expr round(($ys * ($bottom - $top)) + $top + $yetol)] 365 ;# yedge is new near-top edge in this case (moving up) 366 } 367 set retol [expr ($xe-$xs)*($right-$left)*$rtol] 368 set letol [expr ($xe-$xs)*($right-$left)*$ltol] 369 set rightedge \ 370 [expr round(($xe * ($right - $left)) + $left - $retol)] 371 set leftedge [expr round(($xs * ($right - $left)) + $left + $letol)] 372 set np [lindex [$w qget [$can find closest $rightedge $yedge 1 text]] 0] 373 ;# get hier. item closest to yedge 374 set textleft [lindex [$can coords txt:$np] 0] 375 if {($textleft < $leftedge) || ($textleft > $rightedge)} { 376 $can xview moveto \ 377 [expr ($textleft - $left) / ($right - $left) - ($xe-$xs)/2] 378 } 379 } else { ;# not follow item 380 eval {$can yview} $args 381 } 382} 383 384 385 386proc hierarchy_dir {w args} { 387 uplevel [list hierarchy $w -root [pwd] \ 388 -nodelook {namespace inscope ::Widget::Hierarchy FileLook} \ 389 -command {namespace inscope ::Widget::Hierarchy FileActivate} \ 390 -browsecmd {namespace inscope ::Widget::Hierarchy FileList}] \ 391 $args 392} 393 394proc hierarchy_widget {w args} { 395 uplevel [list hierarchy $w -root . \ 396 -nodelook {namespace inscope ::Widget::Hierarchy WidgetLook} \ 397 -command {namespace inscope ::Widget::Hierarchy WidgetActivate} \ 398 -browsecmd {namespace inscope ::Widget::Hierarchy WidgetList}] \ 399 $args 400} 401 402namespace eval ::Widget::Hierarchy {; 403 404;proc construct w { 405 upvar \#0 [namespace current]::$w data 406 407 ## Private variables 408 array set data [list \ 409 hasnodelook 0 \ 410 halfpstk [expr $data(-padstack)/2] \ 411 width 400 \ 412 ] 413 414 grid $data(canvas) $data(yscrollbar) -sticky news 415 grid $data(xscrollbar) -sticky ew 416 grid columnconfig $w 0 -weight 1 417 grid rowconfig $w 0 -weight 1 418 bind $data(canvas) <Configure> [namespace code [list Resize $w %w %h]] 419} 420 421;proc init w { 422 upvar \#0 [namespace current]::$w data 423 424 set data(:$data(-root),showkids) 0 425 ExpandNodeN $w $data(-root) $data(-expand) 426 if {[catch {$w see $data(-root)}]} { 427 $data(basecmd) configure -scrollregion {0 0 1 1} 428 } 429} 430 431;proc configure {w args} { 432 upvar \#0 [namespace current]::$w data 433 434 set truth {^(1|yes|true|on)$} 435 array set config { resize 0 root 0 showall 0 } 436 437 set data(yfollow_item) 1 438 set data(yfollow_ttol) 0.1 439 set data(yfollow_btol) 0.1 440 set data(yfollow_rtol) 0.2 441 set data(yfollow_ltol) 0.1 442 443 foreach {key val} $args { 444 switch -- $key { 445 -autoscrollbar { 446 set val [regexp -nocase $truth $val] 447 if {$val} { 448 set config(resize) 1 449 } else { 450 grid $data(xscrollbar) 451 grid $data(yscrollbar) 452 } 453 } 454 -decoration { set val [regexp -nocase $truth $val] } 455 -padstack { set data(halfpstk) [expr {$val/2}] } 456 -nodelook { 457 ## We set this special bool val because it saves some 458 ## computation in ExpandNode, a deeply nested proc 459 set data(hasnodelook) [string compare $val {}] 460 } 461 -root { 462 if {[info exists data(:$data(-root),showkids)]} { 463 ## All data about items and selection should be 464 ## cleared and the items deleted 465 foreach name [concat [array names data :*] \ 466 [array names data S,*]] {unset data($name)} 467 $data(basecmd) delete all 468 set data(-root) $val 469 set config(root) 1 470 ## Avoid setting data($key) below 471 continue 472 } 473 } 474 -selectbackground { 475 foreach i [array names data S,*] { 476 $data(basecmd) itemconfigure [string range $i 2 end] \ 477 -fill $val 478 } 479 } 480 -state { 481 if {![regexp {^(normal|disabled)$} $val junk val]} { 482 return -code error "bad state value \"$val\":\ 483 must be normal or disabled" 484 } 485 } 486 -showall - 487 -showfiles { 488 set val [regexp -nocase $truth $val] 489 if {$val == $data($key)} continue 490 set config(showall) 1 491 } 492 } 493 set data($key) $val 494 } 495 if {$config(root)} { 496 set data(:$val,showkids) 0 497 ExpandNodeN $w $val $data(-expand) 498 } elseif {$config(showall) && [info exists data(:$data(-root),showkids)]} { 499 _refresh $w 500 } elseif {$config(resize)} { 501 Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)] 502 } 503} 504 505## Cryptic source code arguments explained: 506## (these, or a similar form, might appear as variables later) 507## np == node path 508## cnp == changed np 509## knp == kids np 510## xcnp == extra cnp 511 512;proc _index { w idx } { 513 upvar \#0 [namespace current]::$w data 514 set c $data(basecmd) 515 if {[string match all $idx]} { 516 return [$c find withtag box] 517 } elseif {[regexp {^(root|anchor)$} $idx]} { 518 return [$c find withtag box:$data(-root)] 519 } 520 foreach i [$c find withtag $idx] { 521 if {[string match rec* [$c type $i]]} { return $i } 522 } 523 if {[regexp {@(-?[0-9]+),(-?[0-9]+)} $idx z x y]} { 524 return [$c find closest [$w canvasx $x] [$w canvasy $y] 1 text] 525 } 526 foreach i [$c find withtag box:[lindex $idx 0]] { return $i } 527 return -code error "bad hierarchy index \"$idx\":\ 528 must be current, @x,y, a number, or a node name" 529} 530 531;proc _selection { w args } { 532 if {[string match {} $args]} { 533 return -code error \ 534 "wrong \# args: should be \"$w selection option args\"" 535 } 536 upvar \#0 [namespace current]::$w data 537 set err [catch {_index $w [lindex $args 1]} idx] 538 switch -glob -- [lindex $args 0] { 539 an* { 540 ## anchor 541 ## stubbed out - too complicated to support 542 } 543 cl* { 544 ## clear 545 set c $data(basecmd) 546 if {$err} { 547 foreach arg [array names data S,*] { unset data($arg) } 548 $c itemconfig box -fill {} 549 } else { 550 catch {unset data(S,$idx)} 551 $c itemconfig $idx -fill {} 552 foreach idx [lrange $args 2 end] { 553 if {[catch {_index $w $idx} idx]} { 554 catch {unset data(S,$idx)} 555 $c itemconfig $idx -fill {} 556 } 557 } 558 } 559 } 560 in* { 561 ## includes 562 if {$err} { 563 if {[llength $args]==2} { 564 return -code error $idx 565 } else { 566 return -code error "wrong \# args:\ 567 should be \"$w selection includes index\"" 568 } 569 } 570 return [info exists data(S,$idx)] 571 } 572 se* { 573 ## set 574 if {$err} { 575 if {[string compare {} $args]} return 576 return -code error "wrong \# args:\ 577 should be \"$w selection set index ?index ...?\"" 578 } else { 579 set c $data(basecmd); set col $data(-selectbackground) 580 if {[string match all [lindex $args 1]]} { 581 foreach i $idx { set data(S,$i) 1 } 582 $c itemconfig box -fill $col 583 } else { 584 set data(S,$idx) 1 585 $c itemconfig $idx -fill $col 586 foreach idx [lrange $args 2 end] { 587 if {![catch {_index $w $idx} idx]} { 588 set data(S,$idx) 1 589 $c itemconfig $idx -fill $col 590 } 591 } 592 } 593 } 594 } 595 default { 596 return -code error "bad selection option \"[lindex $args 0]\":\ 597 must be clear, includes, set" 598 } 599 } 600} 601 602;proc _curselection {w} { 603 upvar \#0 [namespace current]::$w data 604 605 set res {} 606 foreach i [array names data S,*] { lappend res [string range $i 2 end] } 607 return $res 608} 609 610;proc _get {w args} { 611 upvar \#0 [namespace current]::$w data 612 613 set nps {} 614 foreach arg $args { 615 if {![catch {_index $w $arg} idx] && \ 616 [string compare {} $idx]} { 617 set tags [$data(basecmd) gettags $idx] 618 if {[set i [lsearch -glob $tags box:*]]>-1} { 619 lappend nps [string range [lindex $tags $i] 4 end] 620 } 621 } 622 } 623 return $nps 624} 625 626;proc _qget {w args} { 627 upvar \#0 [namespace current]::$w data 628 629 ## Quick get. Avoids expensive _index call 630 set nps {} 631 foreach arg $args { 632 set tags [$data(basecmd) itemcget $arg -tags] 633 if {[set i [lsearch -glob $tags box:*]]>-1} { 634 lappend nps [string range [lindex $tags $i] 4 end] 635 } 636 } 637 return $nps 638} 639 640;proc _see {w args} { 641 upvar \#0 [namespace current]::$w data 642 643 if {[catch {_index $w $args} idx]} { 644 return -code error $idx 645 } elseif {[string compare {} $idx]} { 646 set c $data(basecmd) 647 foreach {x y x1 y1} [$c bbox $idx] {top btm} [$c yview] { 648 set stk [lindex [$c cget -scrollregion] 3] 649 set pos [expr (($y1+$y)/2.0)/$stk - ($btm-$top)/2.0] 650 } 651 set np [lindex [$w qget $idx] 0] 652 set maxright [lindex [$c cget -scrollregion] 2] 653 set textleft [lindex [$c coords txt:$np] 0] 654 set xpos [expr ($textleft/$maxright)] 655 656 $c yview moveto $pos 657 $c xview moveto $xpos 658 } 659} 660 661;proc _centreitem {w args xtoll xtolr ytolt ytolb} { 662 upvar \#0 [namespace current]::$w data 663 664 if {[catch {_index $w $args} idx]} { 665 return -code error $idx 666 } elseif {[string compare {} $idx]} { 667 set c $data(basecmd) 668 set np [lindex [$w qget $idx] 0] 669 foreach {x0 y0} [$c coords txt:$np] { 670 foreach {left top right bottom} [$c cget -scrollregion] { 671 set xfrac [expr ($x0 - $left) / ($right - $left)] 672 set yfrac [expr ($y0 - $top) / ($bottom - $top)] 673 } 674 } 675 foreach {toleft toright} [$c xview] { 676 foreach {totop tobot} [$c yview] { 677 if {$xfrac > $toleft} { 678 ;# beyond left edge 679 if {$xfrac < $toright} { 680 ;# within right edge 681 set xpos [expr ($xfrac - $toleft) / ($toright - $toleft)] 682 if {($xpos > $xtoll) && ($xpos < $xtolr)} { 683 set movex 0 ;# within tolerance, no move 684 } else { 685 set movex 1 686 } 687 } else { 688 set movex 1 689 } 690 } else { 691 set movex 1 692 } 693 694 if {$yfrac > $totop} { 695 ;# beyond top edge 696 if {$yfrac < $tobot} { 697 ;# within bottom edge 698 set ypos [expr ($yfrac - $totop) / ($tobot - $totop)] 699 if {($ypos > $ytolt) && ($ypos < $ytolb)} { 700 set movey 0 ;# within tolerance, no move 701 } else { 702 set movey 1 703 } 704 } else { 705 set movey 1 706 } 707 } else { 708 set movey 1 709 } 710 } 711 712 if {$movex == 1} { 713 $c xview moveto [expr $xfrac - (($toright - $toleft) / 2.0)] 714 } 715 if {$movey == 1} { 716 $c yview moveto [expr $yfrac - (($tobot - $totop) / 2.0)] 717 } 718 } 719 } 720} 721 722;proc _yfollowstate {w} { 723 upvar \#0 [namespace current]::$w data 724 725 return [list $data(yfollow_item) $data(yfollow_ltol) $data(yfollow_rtol) \ 726 $data(yfollow_ttol) $data(yfollow_btol)] 727} 728 729;proc _ynofollowitem {w} { 730 upvar \#0 [namespace current]::$w data 731 732 set data(yfollow_item) 0 733} 734 735;proc _yfollowitem {w ltol rtol ttol btol} { 736 upvar \#0 [namespace current]::$w data 737 738 set data(yfollow_item) 1 739 set data(yfollow_ltol) $ltol 740 set data(yfollow_rtol) $rtol 741 set data(yfollow_ttol) $ttol 742 set data(yfollow_btol) $btol 743} 744 745;proc _refresh {w} { 746 upvar \#0 [namespace current]::$w data 747 748 array set expanded [array get data ":*,showkids"] 749 foreach i [concat [array names data :*] \ 750 [array names data S,*]] {unset data($i)} 751 $data(basecmd) delete all 752 ## -dec makes it sort in root-first order 753 foreach i [lsort -ascii -decreasing [array names expanded]] { 754 if {$expanded($i)} { 755 regexp {^:(.*),showkids$} $i junk np 756 ## Quick way to remove the last element of a list 757 set prnt [lreplace $np end end] 758 ## checks to get rid of dead, previously opened nodes 759 if {[string match {} $prnt] || ([info exists data(:$prnt,kids)] \ 760 && [lsearch -exact $data(:$prnt,kids) \ 761 [lindex $np end]] != -1)} { 762 set data($i) 0 763 ExpandNode $w $np 764 } 765 } 766 } 767 Redraw $w $data(-root) 768 Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)] 769} 770 771;proc _size {w} { 772 upvar \#0 [namespace current]::$w data 773 return [llength [$data(basecmd) find withtag box]] 774} 775 776## Added by Kish Shen 98-11-30 777## Returns the index of an item with the path name np 778;proc _indexnp { w np } { 779 upvar \#0 [namespace current]::$w data 780 781 set c $data(basecmd) 782 return [$c find withtag box:$np] 783} 784 785## Added by Kish Shen 99-1-12 786;proc _isopen { w np } { 787 upvar \#0 [namespace current]::$w data 788 789 return $data(:$np,showkids) 790} 791 792## This will be the one called by <Double-Button-1> on the canvas, 793## if -state is normal, so we have to make sure that $w is correct. 794## 795;proc _toggle { w index } { 796 toggle $w $index toggle 797} 798 799;proc _close { w index } { 800 toggle $w $index close 801} 802 803;proc _open { w index } { 804 toggle $w $index open 805} 806 807;proc _expandbranch { w np arg depth aux} { 808 809 return [ExpandOneBranchN $w $np $arg $depth $aux] 810} 811 812;proc toggle { w index which } { 813 if {[string compare Hierarchy [winfo class $w]]} { 814 set w [winfo parent $w] 815 } 816 upvar \#0 [namespace current]::$w data 817 818 if {[string match {} [set np [_get $w $index]]]} return 819 set np [lindex $np 0] 820 821 set old [$data(basecmd) cget -cursor] 822 $data(basecmd) config -cursor watch 823 update 824 switch $which { 825 close { CollapseNodeAll $w $np } 826 open { ExpandNodeN $w $np 1 } 827 toggle { 828 if {$data(:$np,showkids)} { 829 CollapseNodeAll $w $np 830 } else { 831 ExpandNodeN $w $np 1 832 } 833 } 834 } 835 if {[string compare {} $data(-command)]} { 836 uplevel \#0 $data(-command) [list $w $np $data(:$np,showkids)] 837 } 838 $data(basecmd) config -cursor $old 839 return 840} 841 842;proc Resize { w wid hgt } { 843 upvar \#0 [namespace current]::$w data 844 set c $data(basecmd) 845 if {[string compare {} [set box [$c bbox image text]]]} { 846 set X [lindex $box 2] 847 if {$data(-autoscrollbar)} { 848 set Y [lindex $box 3] 849 if {$wid>$X} { 850 set X $wid 851 grid remove $data(xscrollbar) 852 } else { 853 grid $data(xscrollbar) 854 } 855 if {$hgt>$Y} { 856 set Y $hgt 857 grid remove $data(yscrollbar) 858 } else { 859 grid $data(yscrollbar) 860 } 861 $c config -scrollregion "0 0 $X $Y" 862 } 863 ## This makes full width highlight boxes 864 ## data(width) is the default width of boxes 865 if {$X>$data(width)} { 866 set data(width) $X 867 foreach b [$c find withtag box] { 868 foreach {x y x1 y1} [$c coords $b] { $c coords $b 0 $y $X $y1 } 869 } 870 } 871 } elseif {$data(-autoscrollbar)} { 872 grid remove $data(xscrollbar) $data(yscrollbar) 873 } 874} 875 876;proc CollapseNodeAll { w np } { 877 if {[CollapseNode $w $np]} { 878 upvar \#0 [namespace current]::$w data 879 Redraw $w $np 880 DiscardChildren $w $np 881 Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)] 882 } 883} 884 885# expand mth node nth times, calling aux at each level 886;proc ExpandOneBranchN {w np m n aux} { 887 upvar \#0 [namespace current]::$w data 888 889 incr m -1 ;# reduce by 1 as lists starts from 0 890 set noerror 1 891 if {$aux != {}} { 892 foreach {procname args} $aux {break} 893 set makecall 1 894 } else { 895 set makecall 0 896 } 897 for {set np1 $np} {1} {incr n -1} { 898 if {![$w isopen $np1]} { 899 if {![ExpandNode $w $np1]} { 900 set noerror 0 901 break 902 } 903 } 904 if {$makecall} { 905 uplevel \#0 $procname [list $n $np1] $args 906 } 907 908 ;# get mth child's path name using browsecmd 909 set child [lindex [uplevel \#0 $data(-browsecmd) [list $w $np1]] $m] 910 if {[string match {} $child]} { 911 set noerror 0 912 break 913 } else { 914 set np1 "$np1 [list $child]" 915 } 916 if {$n == 1} {break} 917 } 918 Redraw $w $np 919 Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)] 920 return [list $noerror $n $np1] 921} 922 923;proc ExpandNodeN { w np n } { 924 upvar \#0 [namespace current]::$w data 925 if {[ExpandNodeN_aux $w $np $n] || \ 926 ([string compare $data(-root) {}] && \ 927 ![string compare $data(-root) $np])} { 928 Redraw $w $np 929 Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)] 930 } 931} 932 933;proc ExpandNodeN_aux { w np n } { 934 if {![ExpandNode $w $np]} { return 0 } 935 if {$n==1} { return 1 } 936 incr n -1 937 upvar \#0 [namespace current]::$w data 938 foreach k $data(:$np,kids) { 939 ExpandNodeN_aux $w "$np [list $k]" $n 940 } 941 return 1 942} 943 944######################################################################## 945## 946## Private routines to collapse and expand a single node w/o redrawing 947## Most routines return 0/1 to indicate if any change has occurred 948## 949######################################################################## 950 951;proc ExpandNode { w np } { 952 upvar \#0 [namespace current]::$w data 953 954 if {$data(:$np,showkids)} { return 0 } 955 set data(:$np,showkids) 1 956 if {![info exists data(:$np,kids)]} { 957 if {[string compare $data(-browsecmd) {}]} { 958 set data(:$np,kids) [uplevel \#0 $data(-browsecmd) [list $w $np]] 959 } else { 960 set data(:$np,kids) {} 961 } 962 } 963 if $data(hasnodelook) { 964 set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 1]] 965 } else { 966 set data(:$np,look) {} 967 } 968 if {[string match {} $data(:$np,kids)]} { 969 ## This is needed when there are no kids to make sure the 970 ## look of the node will be updated appropriately 971 foreach {txt font img fg} $data(:$np,look) { 972 lappend tags box:$np box $np 973 set c $data(basecmd) 974 if {[string compare $img {}]} { 975 ## Catch just in case the image doesn't exist 976 catch { 977 $c itemconfigure img:$np -image $img 978 lappend tags $img 979 } 980 } 981 if {[string compare $txt {}]} { 982 if {[string match {} $font]} { set font $data(-font) } 983 if {[string match {} $fg]} { set fg $data(-foreground) } 984 $c itemconfigure txt:$np -fill $fg -text $txt -font $font 985 if {[string compare $np $txt]} { lappend tags [list txt: $txt] } 986 } 987 $c itemconfigure box:$np -tags $tags 988 ## We only want to go through once 989 break 990 } 991 return 0 992 } 993 foreach k $data(:$np,kids) { 994 set knp "$np [list $k]" 995 ## Check to make sure it doesn't already exist, 996 ## in case we are refreshing the node or something 997 if {![info exists data(:$knp,showkids)]} { set data(:$knp,showkids) 0 } 998 if $data(hasnodelook) { 999 set data(:$knp,look) [uplevel \#0 $data(-nodelook) [list $w $knp 0]] 1000 } else { 1001 set data(:$knp,look) {} 1002 } 1003 } 1004 return 1 1005} 1006 1007;proc CollapseNode { w np } { 1008 upvar \#0 [namespace current]::$w data 1009 if {!$data(:$np,showkids)} { return 0 } 1010 set data(:$np,showkids) 0 1011 if {[string match {} $data(:$np,kids)]} { return 0 } 1012 if {[string compare $data(-nodelook) {}]} { 1013 set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 0]] 1014 } else { 1015 set data(:$np,look) {} 1016 } 1017 foreach k $data(:$np,kids) { CollapseNode $w "$np [list $k]" } 1018 return 1 1019} 1020 1021;proc DiscardChildren { w np } { 1022 upvar \#0 [namespace current]::$w data 1023 if {[info exists data(:$np,kids)]} { 1024 foreach k $data(:$np,kids) { 1025 set knp "$np [list $k]" 1026 $data(basecmd) delete img:$knp txt:$knp box:$knp 1027 foreach i {showkids look stkusg stack iwidth offset} { 1028 catch {unset data(:$knp,$i)} 1029 } 1030 DiscardChildren $w $knp 1031 } 1032 unset data(:$np,kids) 1033 } 1034} 1035 1036## REDRAW mechanism 1037## 2 parts: recompute offsets of all children from changed node path 1038## then redraw children based on their offsets and look 1039## 1040;proc Redraw { w cnp } { 1041 upvar \#0 [namespace current]::$w data 1042 1043 set c $data(basecmd) 1044 # When a node changes, the positions of a whole lot of things 1045 # change. The size of the scroll region also changes. 1046 $c delete decor 1047 1048 # Calculate the new offset locations of everything 1049 Recompute $w $data(-root) [lrange $cnp 1 end] 1050 1051 # Next recursively move all the bits around to their correct positions. 1052 # We choose an initial point (4,4) to begin at. 1053 Redraw_aux $w $data(-root) 4 4 1054 1055 # Necessary to make sure find closest gets the right item 1056 # ordering: image > text > box 1057 after idle "catch { [list $c] raise image text; [list $c] lower box text }" 1058} 1059 1060## RECOMPUTE recurses through the tree working out the relative offsets 1061## of children from their parents in terms of stack values. 1062## 1063## "cnp" is either empty or a node name which indicates where the only 1064## changes have occured in the hierarchy since the last call to Recompute. 1065## This is used because when a node is toggled on/off deep in the 1066## hierarchy then not all the positions of items need to be recomputed. 1067## The only ones that do are everything below the changed node (of 1068## course), and also everything which might depend on the stack usage of 1069## that node (i.e. everything above it). Specifically the usages of the 1070## changed node's siblings do *not* need to be recomputed. 1071## 1072;proc Recompute { w np cnp } { 1073 upvar \#0 [namespace current]::$w data 1074 # If the cnp now has only one element then 1075 # it must be one of the children of the current node. 1076 # We do not need to Recompute the usages of its siblings if it is. 1077 set cnode_is_child [expr {[llength $cnp]==1}] 1078 if {$cnode_is_child} { 1079 set cnode [lindex $cnp 0] 1080 } else { 1081 set xcnp [lrange $cnp 1 end] 1082 } 1083 1084 # Run through the children, recursively calculating their usage of 1085 # stack real-estate, and allocating an intial placement for each child 1086 # 1087 # Values do not need to be recomputed for siblings of the changed 1088 # node and their descendants. For the cnode itself, in the 1089 # recursive call we set the value of cnode to {} to prevent 1090 # any further cnode checks. 1091 1092 set children_stack 0 1093 if {$data(:$np,showkids)} { 1094 foreach k $data(:$np,kids) { 1095 set knp "$np [list $k]" 1096 set data(:$knp,offset) $children_stack 1097 if {$cnode_is_child && [string match $cnode $k]} { 1098 set data(:$knp,stkusg) [Recompute $w $knp {}] 1099 } elseif {!$cnode_is_child} { 1100 set data(:$knp,stkusg) [Recompute $w $knp $xcnp] 1101 } 1102 incr children_stack $data(:$knp,stkusg) 1103 incr children_stack $data(-padstack) 1104 } 1105 } 1106 1107 ## Make the image/text if they don't exist. 1108 ## Positioning occurs in Redraw_aux. 1109 ## And calculate the stack usage of our little piece of the world. 1110 set img_height 0; set img_width 0; set txt_width 0; set txt_height 0 1111 1112 foreach {txt font img fg} $data(:$np,look) { 1113 lappend tags box:$np box $np 1114 set c $data(basecmd) 1115 if {[string compare $img {}]} { 1116 if {[string match {} [$c find withtag img:$np]]} { 1117 $c create image 0 0 -anchor nw -tags [list img:$np image] 1118 } 1119 ## Catch just in case the image doesn't exist 1120 catch { 1121 $c itemconfigure img:$np -image $img 1122 lappend tags $img 1123 foreach {x y img_width img_height} [$c bbox img:$np] { 1124 incr img_width -$x; incr img_height -$y 1125 } 1126 } 1127 } 1128 if {[string compare $txt {}]} { 1129 if {[string match {} [$c find withtag txt:$np]]} { 1130 $c create text 0 0 -anchor nw -tags [list txt:$np text] 1131 } 1132 if {[string match {} $font]} { set font $data(-font) } 1133 if {[string match {} $fg]} { set fg $data(-foreground) } 1134 $c itemconfigure txt:$np -fill $fg -text $txt -font $font 1135 if {[string compare $np $txt]} { lappend tags [list txt: $txt] } 1136 foreach {x y txt_width txt_height} [$c bbox txt:$np] { 1137 1138 # Kish 2003-03-14: Mac Tcl 8.4.2 does not like --1 as increment 1139 incr txt_width [expr -$x]; incr txt_height [expr -$y] 1140 } 1141 } 1142 if {[string match {} [$c find withtag box:$np]]} { 1143 $c create rect 0 0 1 1 -tags [list box:$np box] -outline {} 1144 } 1145 $c itemconfigure box:$np -tags $tags 1146 ## We only want to go through this once 1147 break 1148 } 1149 1150 set stack [expr {$txt_height>$img_height?$txt_height:$img_height}] 1151 1152 # Now reposition the children downward by "stack" 1153 set overall_stack [expr {$children_stack+$stack}] 1154 1155 if {$data(:$np,showkids)} { 1156 set off [expr {$stack+$data(-padstack)}] 1157 foreach k $data(:$np,kids) { 1158 set knp "$np [list $k]" 1159 incr data(:$knp,offset) $off 1160 } 1161 } 1162 # remember some facts for locating the image and drawing decor 1163 array set data [list :$np,stack $stack :$np,iwidth $img_width] 1164 1165 return $overall_stack 1166} 1167 1168;proc Redraw_aux {w np deppos stkpos} { 1169 upvar \#0 [namespace current]::$w data 1170 1171 set c $data(basecmd) 1172 $c coords img:$np $deppos $stkpos 1173 $c coords txt:$np [expr {$deppos+$data(:$np,iwidth)+$data(-ipad)}] $stkpos 1174 $c coords box:$np 0 [expr {$stkpos-$data(halfpstk)}] \ 1175 $data(width) [expr {$stkpos+$data(:$np,stack)+$data(halfpstk)}] 1176 1177 if {!$data(:$np,showkids) || [string match {} $data(:$np,kids)]} return 1178 1179 set minkid_stkpos 100000 1180 set maxkid_stkpos 0 1181 set bar_deppos [expr {$deppos+$data(-paddepth)/2}] 1182 set kid_deppos [expr {$deppos+$data(-paddepth)}] 1183 1184 foreach k $data(:$np,kids) { 1185 set knp "$np [list $k]" 1186 set kid_stkpos [expr {$stkpos+$data(:$knp,offset)}] 1187 Redraw_aux $w $knp $kid_deppos $kid_stkpos 1188 1189 if {$data(-decoration)} { 1190 if {$kid_stkpos<$minkid_stkpos} {set minkid_stkpos $kid_stkpos} 1191 set kid_stkpos [expr {$kid_stkpos+$data(:$knp,stack)/2}] 1192 if {$kid_stkpos>$maxkid_stkpos} {set maxkid_stkpos $kid_stkpos} 1193 1194 $c create line $bar_deppos $kid_stkpos $kid_deppos $kid_stkpos \ 1195 -width 1 -tags decor 1196 } 1197 } 1198 if {$data(-decoration)} { 1199 $c create line $bar_deppos $minkid_stkpos $bar_deppos $maxkid_stkpos \ 1200 -width 1 -tags decor 1201 } 1202} 1203 1204 1205## 1206## DEFAULT BINDINGS FOR HIERARCHY 1207## 1208## Since we give no border to the frame, all Hierarchy bindings 1209## will always register on the canvas widget 1210## 1211bind Hierarchy <Double-Button-1> { 1212 set w [winfo parent %W] 1213 if {[string match normal [$w cget -state]]} { 1214 $w toggle @%x,%y 1215 } 1216} 1217bind Hierarchy <ButtonPress-1> { 1218 if {[winfo exists %W]} { 1219 namespace eval ::Widget::Hierarchy \ 1220 [list BeginSelect [winfo parent %W] @%x,%y] 1221 } 1222} 1223bind Hierarchy <B1-Motion> { 1224 set tkPriv(x) %x 1225 set tkPriv(y) %y 1226 namespace eval ::Widget::Hierarchy [list Motion [winfo parent %W] @%x,%y] 1227} 1228bind Hierarchy <ButtonRelease-1> { tkCancelRepeat } 1229bind Hierarchy <Shift-1> [namespace code \ 1230 { BeginExtend [winfo parent %W] @%x,%y }] 1231bind Hierarchy <Control-1> [namespace code \ 1232 { BeginToggle [winfo parent %W] @%x,%y }] 1233bind Hierarchy <B1-Leave> { 1234 set tkPriv(x) %x 1235 set tkPriv(y) %y 1236 namespace eval ::Widget::Hierarchy [list AutoScan [winfo parent %W]] 1237} 1238bind Hierarchy <B1-Enter> { tkCancelRepeat } 1239 1240# Mouse wheel scrolling on X11 1241bind Hierarchy <Button-4> { %W yview scroll -1 units } 1242bind Hierarchy <Button-5> { %W yview scroll 1 units } 1243# Mouse wheel scrolling on Windows (doesn't work...) 1244bind Hierarchy <MouseWheel> { %W yview scroll [expr {-%D/120}] units } 1245 1246## Should reserve L/R U/D for traversing nodes 1247bind Hierarchy <Up> { %W yview scroll -1 units } 1248bind Hierarchy <Down> { %W yview scroll 1 units } 1249bind Hierarchy <Left> { %W xview scroll -1 units } 1250bind Hierarchy <Right> { %W xview scroll 1 units } 1251 1252bind Hierarchy <Control-Up> { %W yview scroll -1 pages } 1253bind Hierarchy <Control-Down> { %W yview scroll 1 pages } 1254bind Hierarchy <Control-Left> { %W xview scroll -1 pages } 1255bind Hierarchy <Control-Right> { %W xview scroll 1 pages } 1256bind Hierarchy <Prior> { %W yview scroll -1 pages } 1257bind Hierarchy <Next> { %W yview scroll 1 pages } 1258bind Hierarchy <Control-Prior> { %W xview scroll -1 pages } 1259bind Hierarchy <Control-Next> { %W xview scroll 1 pages } 1260bind Hierarchy <Home> { %W xview moveto 0 } 1261bind Hierarchy <End> { %W xview moveto 1 } 1262bind Hierarchy <Control-slash> [namespace code \ 1263 { SelectAll [winfo parent %W] }] 1264bind Hierarchy <Control-backslash> [namespace code \ 1265 { [winfo parent %W] selection clear }] 1266 1267bind Hierarchy <2> { 1268 set tkPriv(x) %x 1269 set tkPriv(y) %y 1270 %W scan mark %x %y 1271} 1272bind Hierarchy <B2-Motion> { 1273 %W scan dragto $tkPriv(x) %y 1274} 1275 1276## BINDING HELPER PROCEDURES 1277## 1278## These are mostly mirrored from the Listbox class bindings. 1279## 1280## Some of these are hacked up to be more efficient by making calls 1281## that require forknowledge of the megawidget structure. 1282## 1283 1284# BeginSelect -- 1285# 1286# This procedure is typically invoked on button-1 presses. It begins 1287# the process of making a selection in the hierarchy. Its exact behavior 1288# depends on the selection mode currently in effect for the hierarchy; 1289# see the Motif documentation for details. 1290# 1291# Arguments: 1292# w - The hierarchy widget. 1293# el - The element for the selection operation (typically the 1294# one under the pointer). Must be in numerical form. 1295 1296;proc BeginSelect {w el} { 1297 global tkPriv 1298 upvar \#0 [namespace current]::$w data 1299 1300 if {[catch {_index $w $el} el]} return 1301 set selected [$w curselection] 1302 _selection $w clear 1303 _selection $w set $el 1304 1305 if {[string compare $data(-selectcmd) {}]} { 1306 uplevel \#0 $data(-selectcmd) [list $w $el $selected] 1307 } 1308 1309 set tkPriv(hierarchyPrev) $el 1310} 1311 1312# Motion -- 1313# 1314# This procedure is called to process mouse motion events while 1315# button 1 is down. It may move or extend the selection, depending 1316# on the hierarchy's selection mode. 1317# 1318# Arguments: 1319# w - The hierarchy widget. 1320# el - The element under the pointer (must be a number). 1321 1322;proc Motion {w el} { 1323 global tkPriv 1324 if {[catch {_index $w $el} el] || \ 1325 [string match $el $tkPriv(hierarchyPrev)]} return 1326 switch [_cget $w -selectmode] { 1327 browse { 1328 _selection $w clear 0 end 1329 if {![catch {_selection $w set $el}]} { 1330 set tkPriv(hierarchyPrev) $el 1331 } 1332 } 1333 multiple { 1334 ## This happens when a double-1 occurs and all the index boxes 1335 ## have changed 1336 if {[catch {_selection $w includes \ 1337 $tkPriv(hierarchyPrev)} inc]} { 1338 set tkPriv(hierarchyPrev) [_index $w $el] 1339 return 1340 } 1341 if {$inc} { 1342 _selection $w set $el 1343 } else { 1344 _selection $w clear $el 1345 } 1346 set tkPriv(hierarchyPrev) $el 1347 } 1348 } 1349} 1350 1351# BeginExtend -- 1352# 1353# This procedure is typically invoked on shift-button-1 presses. It 1354# begins the process of extending a selection in the hierarchy. Its 1355# exact behavior depends on the selection mode currently in effect 1356# for the hierarchy; 1357# 1358# Arguments: 1359# w - The hierarchy widget. 1360# el - The element for the selection operation (typically the 1361# one under the pointer). Must be in numerical form. 1362 1363;proc BeginExtend {w el} { 1364 if {[catch {_index $w $el} el]} return 1365 if {[string match multiple [_cget $w -selectmode]]} { 1366 Motion $w $el 1367 } 1368} 1369 1370# BeginToggle -- 1371# 1372# This procedure is typically invoked on control-button-1 presses. It 1373# begins the process of toggling a selection in the hierarchy. Its 1374# exact behavior depends on the selection mode currently in effect 1375# for the hierarchy; see the Motif documentation for details. 1376# 1377# Arguments: 1378# w - The hierarchy widget. 1379# el - The element for the selection operation (typically the 1380# one under the pointer). Must be in numerical form. 1381 1382;proc BeginToggle {w el} { 1383 global tkPriv 1384 if {[catch {_index $w $el} el]} return 1385 if {[string match multiple [_cget $w -selectmode]]} { 1386 _selection $w anchor $el 1387 if {[_selection $w includes $el]} { 1388 _selection $w clear $el 1389 } else { 1390 _selection $w set $el 1391 } 1392 set tkPriv(hierarchyPrev) $el 1393 } 1394} 1395 1396# AutoScan -- 1397# This procedure is invoked when the mouse leaves an entry window 1398# with button 1 down. It scrolls the window up, down, left, or 1399# right, depending on where the mouse left the window, and reschedules 1400# itself as an "after" command so that the window continues to scroll until 1401# the mouse moves back into the window or the mouse button is released. 1402# 1403# Arguments: 1404# w - The hierarchy widget. 1405 1406;proc AutoScan {w} { 1407 global tkPriv 1408 if {![winfo exists $w]} return 1409 set x $tkPriv(x) 1410 set y $tkPriv(y) 1411 if {$y>=[winfo height $w]} { 1412 $w yview scroll 1 units 1413 } elseif {$y<0} { 1414 $w yview scroll -1 units 1415 } elseif {$x>=[winfo width $w]} { 1416 $w xview scroll 2 units 1417 } elseif {$x<0} { 1418 $w xview scroll -2 units 1419 } else { 1420 return 1421 } 1422 #Motion $w [$w index @$x,$y] 1423 set tkPriv(afterId) [after 50 [namespace current]::AutoScan $w] 1424} 1425 1426# SelectAll 1427# 1428# This procedure is invoked to handle the "select all" operation. 1429# For single and browse mode, it just selects the root element. 1430# Otherwise it selects everything in the widget. 1431# 1432# Arguments: 1433# w - The hierarchy widget. 1434 1435;proc SelectAll w { 1436 if {[regexp (browse|single) [_cget $w -selectmode]]} { 1437 _selection $w clear 1438 _selection $w set root 1439 } else { 1440 _selection $w set all 1441 } 1442} 1443 1444#------------------------------------------------------------ 1445# Default nodelook methods 1446#------------------------------------------------------------ 1447 1448;proc FileLook { w np isopen } { 1449 upvar \#0 [namespace current]::$w data 1450 set path [eval file join $np] 1451 set file [lindex $np end] 1452 set bmp {} 1453 if {[file readable $path]} { 1454 if {[file isdirectory $path]} { 1455 if {$isopen} { 1456 ## We know that kids will always be set by the time 1457 ## the isopen is set to 1 1458 if {[string compare $data(:$np,kids) {}]} { 1459 set bmp idir ;#::Widget::Hierarchy::bmp:dir_minus 1460 } else { 1461 set bmp idir ;#::Widget::Hierarchy::bmp:dir 1462 } 1463 } else { 1464 set bmp idir ;#::Widget::Hierarchy::bmp:dir_plus 1465 } 1466 if 0 { 1467 ## NOTE: accurate, but very expensive 1468# if {[string compare [FileList $w $np] {}]} { 1469# set bmp [expr {$isopen ?\ 1470# {::Widget::Hierarchy::bmp:dir_minus} :\ 1471# {::Widget::Hierarchy::bmp:dir_plus}}] 1472# } else { 1473# set bmp ::Widget::Hierarchy::bmp:dir 1474 set bmp idir 1475 } 1476 } 1477 } 1478 set fg \#000000 1479 } elseif {[string compare $data(-showparent) {}] && \ 1480 [string match $data(-showparent) $file]} { 1481 set fg \#0000FF 1482 set bmp ::Widget::Hierarchy::bmp:up 1483 } else { 1484 set fg \#a9a9a9 1485# if {[file isdirectory $path]} {set bmp ::Widget::Hierarchy::bmp:dir} 1486 if {[file isdirectory $path]} {set bmp idir} } 1487 return [list $file $data(-font) $bmp $fg] 1488} 1489 1490## FileList 1491# ARGS: w hierarchy widget 1492# np node path 1493# Returns: directory listing 1494## 1495;proc FileList { w np } { 1496 set pwd [pwd] 1497 if {[catch "cd \[file join $np\]"]} { 1498 set list {} 1499 } else { 1500 global tcl_platform 1501 upvar \#0 [namespace current]::$w data 1502 set str * 1503 if {!$data(-showfiles)} { append str / } 1504 if {$data(-showall) && [string match unix $tcl_platform(platform)]} { 1505 ## NOTE: Use of non-core lremove 1506 if {[catch {lsort [concat [glob -nocomplain $str] \ 1507 [lremove [glob -nocomplain .$str] {. ..}]]} list]} { 1508 return {} 1509 } 1510 } else { 1511 ## The extra catch is necessary for unusual error conditions 1512 if {[catch {lsort [glob -nocomplain $str]} list]} { 1513 return {} 1514 } 1515 } 1516 set root $data(-root) 1517 if {[string compare {} $data(-showparent)] && \ 1518 [string match $root $np]} { 1519 if {![regexp {^(.:)?/+$} $root] && \ 1520 [string compare [file dir $root] $root]} { 1521 set list [linsert $list 0 $data(-showparent)] 1522 } 1523 } 1524 } 1525 cd $pwd 1526 return $list 1527} 1528 1529;proc FileActivate { w np isopen } { 1530 upvar \#0 [namespace current]::$w data 1531 set path [eval file join $np] 1532 if {[file isdirectory $path]} return 1533 if {[string compare $data(-showparent) {}] && \ 1534 [string match $data(-showparent) [lindex $np end]]} { 1535 $w configure -root [file dir $data(-root)] 1536 } 1537} 1538 1539;proc WidgetLook { W np isopen } { 1540 upvar \#0 [namespace current]::$W data 1541 if {$data(-showall)} { 1542 set w [lindex $np end] 1543 } else { 1544 set w [join $np {}] 1545 regsub {\.\.} $w {.} w 1546 } 1547 if {[string compare [winfo children $w] {}]} {set fg blue} {set fg black} 1548 return [list "\[[winfo class $w]\] [lindex $np end]" {} {} $fg] 1549} 1550 1551;proc WidgetList { W np } { 1552 upvar \#0 [namespace current]::$W data 1553 if {$data(-showall)} { 1554 set w [lindex $np end] 1555 } else { 1556 set w [join $np {}] 1557 regsub {\.\.} $w {.} w 1558 } 1559 set kids {} 1560 foreach i [lsort [winfo children $w]] { 1561 if {$data(-showall)} { 1562 lappend kids $i 1563 } else { 1564 lappend kids [file extension $i] 1565 } 1566 } 1567 return $kids 1568} 1569 1570;proc WidgetActivate { w np isopen } {} 1571 1572image create photo ifile -data { 1573 R0lGODdhEAAQAPIAAAAAAHh4eLi4uPj4+P///wAAAAAAAAAAACwAAAAAEAAQAAADPkixzPOD 1574 yADrWE8qC8WN0+BZAmBq1GMOqwigXFXCrGk/cxjjr27fLtout6n9eMIYMTXsFZsogXRKJf6u 1575 P0kCADv/ 1576} 1577 1578image create photo idir -data { 1579 R0lGODdhEAAQAPIAAAAAAHh4eLi4uPj4APj4+P///wAAAAAAACwAAAAAEAAQAAADPVi63P4w 1580 LkKCtTTnUsXwQqBtAfh910UU4ugGAEucpgnLNY3Gop7folwNOBOeiEYQ0acDpp6pGAFArVqt 1581 hQQAO/// 1582} 1583 1584## BITMAPS 1585## 1586image create bitmap ::Widget::Hierarchy::bmp:dir -data {#define folder_width 16 1587#define folder_height 12 1588static char folder_bits[] = { 1589 0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40, 1590 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};} 1591image create bitmap ::Widget::Hierarchy::bmp:dir_plus -data {#define folder_plus_width 16 1592 #define folder_plus_height 12 1593static char folder_plus_bits[] = { 1594 0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x82, 0x40, 1595 0x82, 0x40, 0xe2, 0x43, 0x82, 0x40, 0x82, 0x40, 0x02, 0x40, 0xfe, 0x7f};} 1596image create bitmap ::Widget::Hierarchy::bmp:dir_minus -data {#define folder_minus_width 16 1597#define folder_minus_height 12 1598static char folder_minus_bits[] = { 1599 0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40, 1600 0x02, 0x40, 0xe2, 0x43, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};} 1601image create bitmap ::Widget::Hierarchy::bmp:up -data {#define up.xbm_width 16 1602#define up.xbm_height 12 1603static unsigned char up.xbm_bits[] = { 1604 0x00, 0x00, 0x10, 0x00, 0x38, 0x00, 0x7c, 0x00, 0xfe, 0x00, 0x38, 0x00, 1605 0x38, 0x00, 0x38, 0x00, 0xf8, 0x7f, 0xf0, 0x7f, 0xe0, 0x7f, 0x00, 0x00};} 1606image create bitmap ::Widget::Hierarchy::bmp:text -data {#define text_width 15 1607#define text_height 14 1608static char text_bits[] = { 1609 0xff,0x07,0x01,0x0c,0x01,0x04,0x01,0x24,0xf9,0x7d,0x01,0x78,0x01,0x40,0xf1, 1610 0x41,0x01,0x40,0x01,0x40,0xf1,0x41,0x01,0x40,0x01,0x40,0xff,0x7f};} 1611 1612}; # end namespace ::Widget::Hierarchy 1613 1614return 1615 1616 1617 1618 1619