# ------------------------------------------------------------ # ::qw::balloon_help # ------------------------------------------------------------ /* { Seems to be used only here so maybe we can replace qw::ballon_help later. Moved all this stuff here because of ::qw::control(tk_is_enabled) */ } ::namespace eval ::qw::balloon_help {} ::variable ::qw::balloon_help::_info; ::variable ::qw::balloon_help::_window ""; ::variable ::qw::balloon_help::_pending ""; ::variable ::qw::balloon_help::_is_enabled 1; ::variable ::qw::balloon_help::_delay 600; ::proc ::qw::balloon_help::initialize {} { ::variable ::qw::balloon_help::_info; ::variable ::qw::balloon_help::_window; ::variable ::qw::balloon_help::_pending; ::variable ::qw::balloon_help::_is_enabled; ::variable ::qw::balloon_help::_delay; ::array set ::qw::balloon_help::_info {}; ::set ::qw::balloon_help::_window [::toplevel .qw_balloon_help_window \ -class Balloonhelp \ -background black \ -borderwidth 1 \ -relief flat ]; ::label $::qw::balloon_help::_window.arrow \ -anchor nw \ -bitmap @[::file join $::qw_library system images arrow.xbm] \ -background #FFFFC0 \ ; ::pack $::qw::balloon_help::_window.arrow -side left -fill y; ::label $::qw::balloon_help::_window.info \ -font {helvetica 8} \ -background #FFFFC0 \ -justify left \ ; ::pack $::qw::balloon_help::_window.info -side left -fill y; ::wm overrideredirect $::qw::balloon_help::_window 1 ::wm withdraw $::qw::balloon_help::_window; } ::proc ::qw::balloon_help::canvas_item_enter {{s_args ""}} { ::variable ::qw::balloon_help::_info; ::variable ::qw::balloon_help::_window; ::variable ::qw::balloon_help::_pending; ::variable ::qw::balloon_help::_is_enabled; ::variable ::qw::balloon_help::_delay; ::if {$::qw::balloon_help::_pending ne ""} { ::after cancel $::qw::balloon_help::_pending; ::set ::qw::balloon_help_pending ""; } ::set ::qw::balloon_help::_pending [::after $::qw::balloon_help::_delay [::list ::qw::balloon_help::canvas_item_show $s_args]]; } ::proc ::qw::balloon_help::canvas_item_leave {{s_args ""}} { ::variable ::qw::balloon_help::_info; ::variable ::qw::balloon_help::_window; ::variable ::qw::balloon_help::_pending; ::variable ::qw::balloon_help::_is_enabled; ::variable ::qw::balloon_help::_delay; ::if {$::qw::balloon_help::_pending ne ""} { ::after cancel $::qw::balloon_help::_pending; ::set ::qw::balloon_help::_pending ""; } ::wm withdraw $::qw::balloon_help::_window; } ::proc ::qw::balloon_help::canvas_item_show {s_args} { ::variable ::qw::balloon_help::_info; ::variable ::qw::balloon_help::_window; ::variable ::qw::balloon_help::_pending; ::variable ::qw::balloon_help::_is_enabled; ::variable ::qw::balloon_help::_delay; ::set ::qw::balloon_help::_pending ""; ::if {!$::qw::balloon_help::_is_enabled} { ::return; } ::if {$::qw::balloon_help::_window eq ""} { ::return; } ::set Canvas [::sargs::get $s_args .canvas]; ::if {![::winfo exists $Canvas]} { ::return; } ::set Tag [::sargs::get $s_args .tag]; ::set BalloonHelp [::sargs::get $s_args .balloon_help]; ::if {$BalloonHelp eq ""} { ::return; } $::qw::balloon_help::_window.info configure -text $BalloonHelp; ::set Coords [$Canvas bbox $Tag]; ::set xShift 10; ::set yShift 0; ::set x [::expr {$xShift+[::winfo rootx $Canvas]+int([::lindex $Coords 0])}]; ::set y [::expr {$yShift+[::winfo rooty $Canvas]+int([::lindex $Coords 3])}]; ::wm geometry $::qw::balloon_help::_window +$x+$y; ::wm deiconify $::qw::balloon_help::_window; ::raise $::qw::balloon_help::_window; } ::qw::balloon_help::initialize; # ------------------------------------------------------------ # ::QW::WIDGET::TREE_STRUCTURE class # ------------------------------------------------------------ ::if {$::rwb1_debug} {::puts "rwb1_debug,qw.qw_tcl,global,1000.17";} ::itcl::class ::QW::WIDGET::TREE_STRUCTURE { inherit iwidgets::Scrolledwidget private variable _nodes; # Array of all nodes by id. private variable _root ""; protected variable _options ""; protected variable _box_width ""; protected variable _box_height ""; protected variable _is_dirty ""; protected variable _icon_open ""; protected variable _icon_closed ""; protected variable _icon_leaf ""; protected variable _canvas; protected variable _box_plus ""; protected variable _box_minus ""; protected variable _box_empty ""; protected variable _s_args ""; protected variable _structure ""; protected variable _owner ""; protected variable _nodes_indexed_by_path; protected variable _active ""; method owner_get {} { ::return $_owner; } method structure_get {} { ::return $_structure; } method get_node_from_path {Path} { ::if {![::info exists _nodes_indexed_by_path($Path)]} { ::qw::bug "314120060116140433" "Could not find node from path \"$Path\"."; } ::return $_nodes_indexed_by_path($Path); } method make_active {{s_args ""}} { ::set Path [::sargs::get $s_args .path]; ::set Node [get_node_from_path $Path]; ::if {$_active eq $Node} { ::return; } ::if {$_active ne ""} { $_active make_inactive $s_args; ::set _active ""; } ::set _active $Node; ::if {$_active ne ""} { $_active make_active $s_args; } } method constructor {args} { ::array set _nodes_indexed_by_path {}; ::set Index [::lsearch -exact $args -s_args]; ::if {$Index>=0} { ::set Index1 [::expr {$Index+1}]; ::set s_args [::lindex $args $Index1]; ::set args [::lreplace $args $Index $Index1]; } ::set _s_args $s_args; ::set _structure [::sargs::get $s_args .structure]; ::set _owner [::sargs::get $s_args .owner]; ::array set _nodes {}; SelectFont::loadfont; ::set _options $::qw::widget::options; ::sargs::var::+= _options [::subst { /item { .box { /plus { .icon { .file {[::file join $::qw_library system images box_plus.gif]} } } /minus { .icon { .file {[::file join $::qw_library system images box_minus.gif]} } } /empty { .icon { .file {[::file join $::qw_library system images box_empty.gif]} } } } .icon {} /leaf { .icon { .file {[::file join $::qw_library system images documenticon.gif]} } } /open { .icon { .file {[::file join $::qw_library system images openfoldericon.gif]} } } /closed { .icon { .file {[::file join $::qw_library system images closedfoldericon.gif]} } } } }]; ::sargs::var::+= _options $s_args; itk_option remove iwidgets::Labeledwidget::state ::set _icon_open [::image create photo -file [option_get /item/open.icon.file]]; ::set _icon_closed [::image create photo -file [option_get /item/closed.icon.file]]; ::set _icon_leaf [::image create photo -file [option_get /item/leaf.icon.file]]; ::set _box_plus [::image create photo -file [option_get /item.box/plus.icon.file]]; ::set _box_minus [::image create photo -file [option_get /item.box/minus.icon.file]]; ::set _box_empty [::image create photo -file [option_get /item.box/empty.icon.file]]; # # Create a clipping frame which will provide the border for # relief display. # itk_component add clipper { frame $itk_interior.clipper } { usual keep -borderwidth -relief -highlightthickness -highlightcolor rename -highlightbackground -background background Background } ::grid $itk_component(clipper) -row 0 -column 0 -sticky nsew ::grid rowconfigure $_interior 0 -weight 1 ::grid columnconfigure $_interior 0 -weight 1 ::set _canvas [::canvas $itk_component(clipper).canvas \ -width 1 \ -height 1 \ -xscrollcommand [::itcl::code $this _scrollWidget $itk_interior.horizsb] \ -yscrollcommand [::itcl::code $this _scrollWidget $itk_interior.vertsb] \ -borderwidth 0 \ -background white \ -highlightthickness 0 \ ]; # -cursor center_ptr /* { itk_component add canvas { ::canvas $itk_component(clipper).canvas \ -cursor center_ptr \ -width 1 \ -height 1 \ -xscrollcommand [::itcl::code $this _scrollWidget $itk_interior.horizsb] \ -yscrollcommand [::itcl::code $this _scrollWidget $itk_interior.vertsb] \ -borderwidth 0 \ -background white \ -highlightthickness 0 } { usual ignore -highlightthickness -highlightcolor ignore -insertbackground -insertborderwidth ignore -insertontime -insertofftime -insertwidth ignore -selectborderwidth ignore -borderwidth } */ } ::grid $_canvas -row 0 -column 0 -sticky nsew ::grid rowconfigure $itk_component(clipper) 0 -weight 1 ::grid columnconfigure $itk_component(clipper) 0 -weight 1 $itk_component(vertsb) configure -command [::itcl::code $_canvas yview] $itk_component(horizsb) configure -command [::itcl::code $_canvas xview] # Add popup menus that can be configured by the user to add new functionality. /* { itk_component add itemMenu { menu $itk_component(list).itemmenu -tearoff 0 } { usual ignore -tearoff rename -cursor -menucursor menuCursor Cursor } itk_component add bgMenu { menu $itk_component(list).bgmenu -tearoff 0 } { usual ignore -tearoff rename -cursor -menucursor menuCursor Cursor } */ } # # Adjust the bind tags to remove the class bindings. Also, add # bindings for mouse button 1 to do selection and button 3 to # display a popup. # #314120030325 ::bindtags $_canvas [::list $_canvas . all] # bind $itk_component(list) [::itcl::code $this _select %x %y] # bind $itk_component(list) [::itcl::code $this _post %x %y] # ::eval itk_initialize $args ::eval itk_initialize $args; # kludge alert # We are not handling -background properly # The way we use icons it looks like we will need a plain white background # We have to see how to set default background to white even though # we inherited the background option. # configure -background white -vscrollmode dynamic -hscrollmode dynamic -selectbackground red # ::set itk_option(-selectbackground) red; configure \ -hscrollmode [option_get /scroll/horizontal.mode] \ -vscrollmode [option_get /scroll/horizontal.mode] \ ; # ::set itk_option(-selectbackground) red; # hide the damn label until we can get rid of altogether # grid forget [component label] # pack forget [component label] # deleting the label causes error when destructing. # itk_component delete label /* { Kludge Alert: Plus/Minus Box size. Because the plus/minus box might not be displayed in any particular item we cannot always use canvas item information to get their size. So we create a temporary box here and get its size once. */ } $_canvas create image 0 0 -image $_box_minus -anchor nw -tags _temp_; ::set BoundingBox [$_canvas bbox _temp_]; $_canvas delete _temp_; ::set _box_width [::expr [::lindex $BoundingBox 2]-[::lindex $BoundingBox 0]]; ::set _box_height [::expr [::lindex $BoundingBox 3]-[::lindex $BoundingBox 1]]; ::set Toplevel [::lindex [bindtags $itk_component(hull)] end-1]; ::bind $Toplevel [::itcl::code $this mouse_wheel %D]; } destructor { ::itcl::delete object $_root; ::set _root ""; ::if {$_is_dirty ne ""} { ::after cancel $_is_dirty; } ::set _is_dirty ""; ::image delete $_icon_open $_icon_closed $_icon_leaf $_box_plus $_box_minus $_box_empty; ::destroy $_canvas; } method option_get {Path} { ::return [::sargs::get_poly $_options $Path]; } method option_set {args} { ::qw::s_args_marshal; ::sargs::var::+= _options $s_args; } method canvas {} {::return $_canvas;} method xview {args} {::return [::eval $_canvas xview $args];} method yview {args} {::return [::eval $_canvas yview $args];} method node {Id} { ::return $_nodes($Id); } method node_class {} { ::return ::QW::WIDGET::TREE_STRUCTURE::NODE; } method nodes_create {args} { ::return [::namespace current]::[::eval [node_class] #auto $args;] } method make_dirty {} { ::if {$_is_dirty eq ""} { ::set Script [::subst -nocommands { ::if {[::qw::command_exists $this]} { $this make_clean; } }]; ::set _is_dirty [::after idle $Script]; } } method make_clean {} { $_canvas configure -scrollregion [$_canvas bbox all]; ::set _is_dirty ""; ::update idletasks; } method nodes_attach {Node} { ::set _nodes([$Node id]) $Node; ::set _nodes_indexed_by_path([$Node path]) $Node; } method nodes_detach {Node} { ::unset _nodes([$Node id]); ::unset _nodes_indexed_by_path([$Node path]); } method active {} { ::return [$_active path]; } method mouse_wheel {Delta} { ::set OldPos [::lindex [$_canvas yview] 0]; ::set MoveBy [::expr {int($Delta/120)*-0.02}]; ::set NewPos [::expr {$OldPos+$MoveBy}]; $_canvas yview moveto $NewPos; } method see {} { /* { Kludge Alert I tried and tried to get the current position of the scrolled viewport. It certainly works when we are stable but the important time I need it is when the window first appears. Nothing works at that time due to the usual tk timing problems. So I find out who my toplevel is and get his requested size as a rough approximation of the size of the viewable area. Crude but effective. To get the toplevel I extract the first component of the widgets's path. */ } ::if {$_active eq ""} {::return $this;} ::set ItemBBox [$_active bounding_box $_active]; ::set ItemTop [::lindex $ItemBBox 1]; ::set ItemBottom [::lindex $ItemBBox 3]; ::set CanvasBBox [$_canvas bbox all]; ::set CanvasTop [::lindex $CanvasBBox 1]; ::set CanvasBottom [::lindex $CanvasBBox 3]; ::if {$CanvasTop<0} {::set CanvasTop 0;} ::set CanvasHeight [::expr {$CanvasBottom-$CanvasTop}]; ::set ViewPortHeight [::winfo reqheight $_canvas]; ::if {$ViewPortHeight==1} { ::set MyToplevel ".[::lindex [::split $itk_component(hull) .] 1]"; ::set ViewPortHeight [::winfo reqheight $MyToplevel]; ::set Top [::expr {double($ItemTop)-double($ViewPortHeight)/2.0}]; ::set Top [::expr {double($Top)/double($CanvasHeight)}]; ::if {$Top<0.0} {::set Top 0.0;} $_canvas yview moveto $Top; return $this; } /* { If we reach this point we can assume we have hit "steady state" and that the sizes reported are valid. However, this code will likely never be called because we do not really need to attempt to see the current position once the user is in control. The only time we really need the see method is when it doesn't work. */ } ::qw::bug 314120030918120133; ::foreach {ViewPortTopRatio ViewPortBottomRatio} [$itk_component(vertsb) get] {}; ::set ViewPortTop [::expr {$ViewPortTopRatio*$CanvasHeight}]; ::set ViewPortBottom [::expr {$ViewPortBottomRatio*$CanvasHeight}]; /* { ::puts " ItemTop:$ItemTop" ::puts " ItemBottom:$ItemBottom" ::puts " ViewPortTop:$ViewPortTop" ::puts " ViewPortBottom:$ViewPortBottom" ::puts " ViewPortTopRatio:$ViewPortTopRatio" ::puts " ViewPortBottomRatio:$ViewPortBottomRatio" ::puts " CanvasTop:$CanvasTop" ::puts " CanvasBottom:$CanvasBottom" ::puts " CanvasHeight:$CanvasHeight" ::puts " ViewPortHeight:$ViewPortHeight" */ } ::if {$ItemTop>=$ViewPortTop&&$ItemBottom<=$ViewPortBottom} {::return $this;} ::set Top [::expr {double($ItemTop)-double($ViewPortHeight)/2.0}]; ::set Top [::expr {double($Top)/double($CanvasHeight)}]; ::if {$Top<0.0} {::set Top 0.0;} $_canvas yview moveto $Top; return $this; } method clear {} { /* { This is a heavy-handed clear of the widget. It destroys the root which recursively destroys all nodes in the tree. The root is reset to "" so that the tree will be completely rebuilt. clear is called when the query command is changed. Note that we do not clear the selected nodes array because the node destructors should automatically do that. */ } ::if {$_root eq ""} {::return $this;} delete object $_root; ::set _root ""; return $this; } method text_get {Path} { # return [::subst [::sargs::set $_options .structure$Path.text]]; ::if {![::sargs::exists $_structure $Path.text]} { ::qw::throw "Could not find .text in \"$Path\""; } ::return [::sargs::get $_structure $Path.text]; } method icon_get {Path} { # ::if {![items $Path]} {::return $_icon_leaf;} ::if {[[node $Path] is_expanded]} {::return $_icon_open;} ::return $_icon_closed; } /* { method kids_get {Path} { ::set Structure [::sargs::get $_structure $Path]; ::set Names [::sargs::subs .structure $Structure]; ::set Result ""; ::foreach Name $Names { ::lappend Result $Path$Name; } ::return $Result; } */ } method draw {} { ::if {$_root eq ""} { # ::set RootId [root_get]; ::set _root [nodes_create]; # $_root id $RootId; $_root tree [::itcl::scope $this]; $_root path ""; # ::set _nodes_indexed_by_path("") $_root; # ::set _root [nodes_create -id $RootId -tree [::itcl::scope $this]]; } $_root draw; make_dirty; } method expand_all {} { ::qw::assert {$_root ne ""} $_root expand_all make_dirty; } method box_width {} {::return $_box_width;} method box_height {} {::return $_box_height;} method box_minus {} {::return $_box_minus;} method box_plus {} {::return $_box_plus;} method box_empty {} {::return $_box_empty;} method item_enter {s_args} { ::set Path [::sargs::get $s_args .path]; ::set Item [::sargs::get $s_args .item]; ::set Tag [::sargs::get $s_args .tag]; ::set BalloonHelp [::sargs::get_poly $_structure $Path.balloon_help]; ::if {$BalloonHelp eq ""} { ::return; } ::qw::balloon_help::canvas_item_enter [::sargs::set $s_args .canvas $_canvas .balloon_help $BalloonHelp]; } method item_leave {s_args} { ::qw::balloon_help::canvas_item_leave; } } # ------------------------------------------------------------ # ::QW::WIDGET::TREE_STRUCTURE::TREE::NODE class # ------------------------------------------------------------ ::itcl::class ::QW::WIDGET::TREE_STRUCTURE::NODE { protected variable _id ""; protected variable _path ""; protected variable _tree ""; protected variable _parent ""; protected variable _index -1; protected variable _kids ""; protected variable _is_expanded 0; protected variable _is_active 0; protected variable _canvas ""; protected variable _text ""; method id {{Src get}} { ::if {$Src eq "get"} {::return $_id;} ::set _id $Src; return $this; } method tree {{Src get}} { ::if {$Src eq "get"} {::return $_tree;} ::set _tree $Src; ::set _canvas [$_tree canvas]; return $this; } method path {{Src get}} { ::if {$Src eq "get"} {::return $_path;} ::set _path $Src; $_tree nodes_attach $this; return $this; } method parent {{Src get}} { ::if {$Src eq "get"} {::return $_parent;} ::set _parent $Src; return $this; } method index {{Src get}} { ::if {$Src eq "get"} {::return $_index;} ::set _index $Src; return $this; } method index_incr {{Src 1}} {::incr _index $Src;return $this;} method text {} { ::if {$_text eq ""} { ::set _text [$_tree text_get $_path]; ::set _text [::string trim $_text]; # ::set _text [::string map {\n " " \r ""} $_text]; } return $_text; } method prev {} { ::if {$_parent eq ""} {::return "";} ::qw::assert {$_index>=0} ::if {!$_index} {::return "";} return [::lindex [$_parent kids] [::expr $_index-1]]; } method next {} { ::if {$_parent eq ""} {::return "";} ::qw::assert {$_index>=0} ::set Items [::llength [$_parent kids]]; ::if {$_index == [::expr $Items-1]} {::return "";} return [::lindex [$_parent kids] [::expr $_index+1]]; } constructor {args} { ::eval configure $args return $this; } destructor { kids_destroy; ::if {[::winfo exists $_canvas]} { undraw; } ::if {$_parent ne ""} {$_parent kids_detach $this} $_tree nodes_detach $this; } method kids_destroy {} { while {[::llength $_kids]} { #::qw::itcl_delete_object [::lindex $_kids end]; # ::rename [::lindex $_kids end] {}; ::itcl::delete object [::lindex $_kids end]; } ::qw::assert {![::llength $_kids]} # ::set _kids ""; return $this; } method kids_detach {Kid} { ::set Index [$Kid index]; ::qw::assert {$Index < [::llength $_kids]} ::set _kids [::lreplace $_kids $Index $Index]; ::for {::set i $Index} {$i<[::llength $_kids]} {::incr i} { [::lindex $_kids $i] index_incr -1; } return $this; } method kids {} { ::if {[::llength $_kids]} { ::return $_kids; } ::foreach Id [::sargs::subs .structure [::sargs::get [$_tree structure_get] $_path]] { ::set Kid [$_tree nodes_create]; $Kid id $Id; $Kid tree $_tree; $Kid path $_path$Id; $Kid parent [::itcl::scope $this]; $Kid index [::llength $_kids]; ::lappend _kids $Kid; } return $_kids; } method is_leaf {} { return [::expr {[::llength [kids]]==0}]; } method is_branch {} {::return [::expr {![is_leaf]}];} method is_expanded {} {::return $_is_expanded;} method is_active {} {::return $_is_active;} method action {{s_args ""}} { ::set Item [::sargs::get $s_args .item]; ::set Operation [::sargs::get $s_args .operation]; ::set Button [::sargs::get $s_args .button]; ::switch -- $Item { text - icon { ::switch -- $Operation { button_down { ::switch -- $Button { 1 { $_tree make_active $s_args; } } } doubleclick { } } } box { ::switch -- $Operation { button_down { ::switch -- $Button { 1 { toggle $s_args; } } } doubleclick { } } } } } method make_active {{s_args ""}} { ::set _is_active 1; $_canvas itemconfigure $this-hilite -fill [$_tree option_get /selection.background]; $_canvas itemconfigure $this-text -fill [$_tree option_get /selection.foreground]; [$_tree owner_get] make_active $s_args; } method make_inactive {{s_args ""}} { $_canvas itemconfigure $this-hilite -fill "" $_canvas itemconfigure $this-text -fill [$_tree option_get /item.foreground]; ::set _is_active 0; return $this; } method toggle {{s_args ""}} { ::if {[is_leaf]} { ::return; } ::if {[is_expanded]} { collapse; ::return; } expand; } method draw {} { # BoxX is the center of the box or if no box, where it would have been. ::if {$_parent eq ""} { ::set BoxX [::expr [$_tree box_width]/2]; } else { ::set BoxX [$_parent center_x $_parent-icon]; } ::set Top 0; ::set Prev [prev]; ::if {$Prev ne ""} { ::set Top [$Prev kids_bottom]; } else { ::if {$_parent ne ""} {::set Top [$_parent bottom $_parent];} } ::if {[is_branch]} { ::if {[is_expanded]} { ::set BoxImage [$_tree box_minus]; } else { ::set BoxImage [$_tree box_plus]; } } else { ::set BoxImage [$_tree box_empty]; } $_canvas create image $BoxX $Top -image $BoxImage -anchor n -tags [::list $this $this-box]; ::set Left [::expr $BoxX+[$_tree box_width]/2]; # Kludge alert: Hard-wired padding between box and icon. ::incr Left 5; $_canvas create image $Left $Top -image [$_tree icon_get $_id] -anchor nw -tags [::list $this $this-icon]; ::set Left [right $this-icon]; $_canvas create text $Left $Top -text [text] -anchor nw -tags [::list $this $this-text] -font [$_tree option_get /item.font]; ::if {$_is_active} { ::set TextColor [$_tree option_get /selection.foreground]; } else { ::set TextColor [$_tree option_get /item.foreground]; } $_canvas itemconfigure $this-text -fill $TextColor; ::set Height [height $this]; $_canvas move $this-box 0 [::expr ($Height-[height $this-box])/2+1]; # We center the icon and text vertically with overall bbox for the item. $_canvas move $this-icon 0 [::expr ($Height-[height $this-icon])/2]; $_canvas move $this-text 0 [::expr ($Height-[height $this-text])/2]; ::set CenterY [center_y $this]; $_canvas lower [$_canvas create line [left $this-icon] $CenterY $BoxX $CenterY -fill grey -tags [::list $this $this-line_h]]; draw_vertical_line; ::if {$_is_active} { ::set Fill [$_tree option_get /selection.background]; } else { ::set Fill [$_tree option_get /item.background]; } ::set SelectBackground [::eval $_canvas create rectangle [bounding_box $this-text]]; $_canvas itemconfigure $SelectBackground -fill $Fill -outline "" -tags [::list $this hilite $this-hilite]; $_canvas lower $SelectBackground; bindings_set; ::if {[is_expanded]} { ::foreach Kid [kids] {$Kid draw;} } } method bindings_set {} { $_canvas bind $this-text [::itcl::code $this action [::sargs .operation button_down .path $_path .item text .button 1]]; $_canvas bind $this-icon [::itcl::code $this action [::sargs .operation button_down .path $_path .item icon .button 1]]; $_canvas bind $this-box [::itcl::code $this action [::sargs .operation button_down .path $_path .item box .button 1]]; $_canvas bind $this-icon [::itcl::code $this action [::sargs .operation doubleclick .path $_path .item icon .button 1]]; $_canvas bind $this-text [::itcl::code $this action [::sargs .operation doubleclick .path $_path .item text .button 1]]; $_canvas bind $this-text [::itcl::code $_tree item_enter [::sargs .operation enter .path $_path .item text .tag $this-text]]; $_canvas bind $this-icon [::itcl::code $_tree item_enter [::sargs .operation enter .path $_path .item icon .tag $this-text]]; $_canvas bind $this-box [::itcl::code $_tree item_enter [::sargs .operation enter .path $_path .item box .tag $this-text]]; $_canvas bind $this-text [::itcl::code $_tree item_leave [::sargs .operation leave .path $_path .item text .tag $this-text]]; $_canvas bind $this-icon [::itcl::code $_tree item_leave [::sargs .operation leave .path $_path .item icon .tag $this-text]]; $_canvas bind $this-box [::itcl::code $_tree item_leave [::sargs .operation leave .path $_path .item box .tag $this-text]]; } method draw_vertical_line {} { ::if {$_parent eq ""} {::return;} $_canvas delete $this-line_v; ::set x [::expr [$_parent center_x $_parent-icon]-1]; ::set Prev [prev]; ::if {$Prev ne ""} { ::set y [$Prev center_y $Prev]; } else { ::set y [$_parent center_y $_parent]; } $_canvas lower [$_canvas create line $x [center_y $this] $x $y -fill grey -tags $this-line_v]; return $this; } method bounding_box {Tag} {::return [$_canvas bbox $Tag];} method height {Tag} {::return [::expr [bottom $Tag]-[top $Tag]];} method width {Tag} {::return [::expr [right $Tag]-[left $Tag]];} method top {Tag} {::return [::lindex [bounding_box $Tag] 1];} method left {Tag} {::return [::lindex [bounding_box $Tag] 0];} method bottom {Tag} {::return [::lindex [bounding_box $Tag] 3];} method right {Tag} {::return [::lindex [bounding_box $Tag] 2];} method center_x {Tag} {::return [::expr [left $Tag]+[width $Tag]/2];} method center_y {Tag} {::return [::expr [top $Tag]+[height $Tag]/2];} method expand {} { ::if {[is_leaf]} { ::return; } ::if {[is_expanded]} { ::return; } ::set _is_expanded 1; ::set Cursor [$_tree cget -cursor]; $_tree configure -cursor $::qw::control(wait_cursor); $_canvas addtag _about_to_move_ overlapping 0 [::expr [bottom $this]+1] [right all] [bottom all]; ::foreach Kid [kids] {$Kid draw;} $_canvas move _about_to_move_ 0 [::expr [kids_bottom] - [bottom $this]]; $_canvas dtag _about_to_move_ _about_to_move_ ::for {::set Parent $this} {$Parent ne ""} {::set Parent [$Parent parent]} { ::if {[$Parent next] ne ""} {[$Parent next] draw_vertical_line;} } ::set x [left $this-box]; ::set y [top $this-box]; $_canvas delete $this-box; $_canvas create image $x $y -image [$_tree box_minus] -anchor nw -tags [::list $this $this-box]; ::set x [left $this-icon]; ::set y [top $this-icon]; $_canvas delete $this-icon; $_canvas create image $x $y -image [$_tree icon_get $_id] -anchor nw -tags [::list $this $this-icon]; $_tree make_dirty; $_tree configure -cursor $Cursor ::return $this; } method expand_all {} { expand; ::foreach Kid [kids] {$Kid expand_all} $_tree make_dirty; ::return $this; } method kids_bottom {} { ::if {![is_expanded]} {::return [bottom $this];} ::if {![::llength [kids]]} {::return [bottom $this];} ::return [[::lindex $_kids end] kids_bottom]; } method collapse {} { ::if {[is_leaf]} { ::return; } ::if {![is_expanded]} { ::return; } $_canvas addtag _about_to_move_ overlapping 0 [::expr [kids_bottom]+1] [right all] [bottom all]; ::set Distance_y [::expr [bottom $this]-[kids_bottom]]; ::foreach Kid [kids] { /* { #rwb__debug the next line results in bad option "undraw"; should be ... commenting it out causes a real mess so I am leaving it in until in also note that there is another copy of a tree widget somewhere, grep for "undraw" */ } $Kid undraw; } ::set _is_expanded 0; $_canvas move _about_to_move_ 0 $Distance_y; $_canvas dtag _about_to_move_ _about_to_move_ ::set x [left $this-icon]; ::set y [top $this-icon]; $_canvas delete $this-icon; $_canvas create image $x $y -image [$_tree icon_get $_id] -anchor nw -tags [::list $this $this-icon]; ::for {::set Parent $this} {$Parent ne ""} {::set Parent [$Parent parent]} { ::if {[$Parent next] ne ""} {[$Parent next] draw_vertical_line;} } ::set x [left $this-box] ::set y [top $this-box] $_canvas delete $this-box; $_canvas create image $x $y -image [$_tree box_plus] -anchor nw -tags [::list $this $this-box]; $_tree make_dirty; } }