From a34d952d98ea2ebf3254cebe6417a9fa5ee2ab39 Mon Sep 17 00:00:00 2001 From: irox Date: Fri, 22 Feb 2002 02:15:45 +0000 Subject: [PATCH] Checked in for Mo DeJong: * itk/library/Toplevel.itk (destructor): * itk/library/Widget.itk (destructor): Remove the hull component after destroying the hull. Destroy any component that still exists after destroying the hull since it must have been created outside the hull. * itk/tests/toplevel.test: * itk/tests/widget.test: Test that a component outside the hull is destroyed when the mega-widget is destroyed. --- itcl/ChangeLog | 13 ++++++++ itcl/itk/library/Toplevel.itk | 6 ++++ itcl/itk/library/Widget.itk | 6 ++++ itcl/itk/tests/toplevel.test | 47 ++++++++++++++++++++++++++++ itcl/itk/tests/widget.test | 73 +++++++++++++++++++++++++++++++++++++++++-- 5 files changed, 142 insertions(+), 3 deletions(-) diff --git a/itcl/ChangeLog b/itcl/ChangeLog index 206796682c..f9ce9980f6 100644 --- a/itcl/ChangeLog +++ b/itcl/ChangeLog @@ -1,3 +1,16 @@ +2002-02-21 Mo DeJong + + * itk/library/Toplevel.itk (destructor): + * itk/library/Widget.itk (destructor): Remove the + hull component after destroying the hull. + Destroy any component that still exists after + destroying the hull since it must have been + created outside the hull. + * itk/tests/toplevel.test: + * itk/tests/widget.test: Test that a component + outside the hull is destroyed when the mega-widget + is destroyed. + 2002-01-15 Keith Seitz * itcl/library/itcl.tcl: Add recognition for "class", "body", diff --git a/itcl/itk/library/Toplevel.itk b/itcl/itk/library/Toplevel.itk index cb01a6db79..a1796221a9 100644 --- a/itcl/itk/library/Toplevel.itk +++ b/itcl/itk/library/Toplevel.itk @@ -63,6 +63,12 @@ itcl::class itk::Toplevel { } destroy $itk_hull } + itk_component delete hull + + # Any remaining components must be outside the hull + foreach component [component] { + destroy [component $component] + } } itk_option define -title title Title "" { diff --git a/itcl/itk/library/Widget.itk b/itcl/itk/library/Widget.itk index 8c455e3211..1474e61d01 100644 --- a/itcl/itk/library/Widget.itk +++ b/itcl/itk/library/Widget.itk @@ -64,6 +64,12 @@ itcl::class itk::Widget { } destroy $itk_hull } + itk_component delete hull + + # Any remaining components must be outside the hull + foreach component [component] { + destroy [component $component] + } } private variable itk_hull "" diff --git a/itcl/itk/tests/toplevel.test b/itcl/itk/tests/toplevel.test index ac6a07f0eb..ed254dd69b 100644 --- a/itcl/itk/tests/toplevel.test +++ b/itcl/itk/tests/toplevel.test @@ -13,8 +13,13 @@ # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. +package require tcltest +namespace import -force ::tcltest::* + if {[string compare test [info procs test]] == 1} then {source defs} +package require Itk + # ---------------------------------------------------------------------- # Toplevel mega-widget # ---------------------------------------------------------------------- @@ -74,7 +79,49 @@ test toplevel-1.6 {when a mega-widget is destroyed, its object is deleted} { itcl::find objects .testToplevel* } {} +test toplevel-1.7 {when an mega-widget object is deleted, its window and any + components are destroyed } { + TestToplevel .delme + set label [.delme component test1] + itcl::delete object .delme + list [winfo exists .delme] [winfo exists $label] +} {0 0} + +test toplevel-1.8 {when a mega-widget object is deleted, its window and any + components are destroyed (even if in another window) } { + itcl::class ButtonTop { + inherit itk::Toplevel + + constructor {args} { + eval itk_initialize $args + + itk_component add button { + button $itk_option(-container).b -text Button + } {} + pack $itk_component(button) + } + + itk_option define -container container Container {} + } + + toplevel .t1 + ButtonTop .t2 -container .t1 + + set button [.t2 component button] + + itcl::delete object .t2 + + set result [list $button [winfo exists $button]] + + itcl::delete class ButtonTop + + set result +} {.t1.b 0} + # ---------------------------------------------------------------------- # Clean up # ---------------------------------------------------------------------- itcl::delete class TestToplevel + +::tcltest::cleanupTests +exit diff --git a/itcl/itk/tests/widget.test b/itcl/itk/tests/widget.test index f793b7d81c..da91291f4a 100644 --- a/itcl/itk/tests/widget.test +++ b/itcl/itk/tests/widget.test @@ -13,8 +13,13 @@ # See the file "license.terms" for information on usage and # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. +package require tcltest +namespace import -force ::tcltest::* + if {[string compare test [info procs test]] == 1} then {source defs} +package require Itk + # ---------------------------------------------------------------------- # Simple mega-widget # ---------------------------------------------------------------------- @@ -157,7 +162,7 @@ test widget-1.10 {check the invocation of "config" code} { } {{} {test message}} test widget-1.11a {configure using the "code" command} { - .testWidget0 do {configure -command [code $this action "button press"]} + .testWidget0 do {configure -command [itcl::code $this action "button press"]} .testWidget0 cget -command } {namespace inscope ::TestWidget {::.testWidget0 action {button press}}} @@ -204,7 +209,7 @@ test widget-1.16 {dead components are removed from the component list} { } {hull test1 test2} test widget-1.17 {use "configbody" command to change "config" code} { - configbody TestWidget::status {lappend status "new"} + itcl::configbody TestWidget::status {lappend status "new"} } {} test widget-1.18 {"config" code can really change} { @@ -215,7 +220,7 @@ test widget-1.18 {"config" code can really change} { } {new new} test widget-1.19 {"config" code can change back} { - configbody TestWidget::status {lappend status $itk_option(-status)} + itcl::configbody TestWidget::status {lappend status $itk_option(-status)} } {} test widget-1.20 {mega-widgets show up on the object list} { @@ -237,7 +242,69 @@ test widget-1.23 {when an object is deleted the widget is destroyed} { winfo exists .testWidget0 } {0} +test widget-1.24 {recreate another test widget} { + TestWidget .testWidget +} {.testWidget} + +test widget-1.25 {when an internal component is destroyed, it is removed from the list of components, and any dead options disappear} { + list [lsort [.testWidget component]] \ + [.testWidget configure] \ + [catch {destroy [.testWidget component test1]}] \ + [.testWidget component] \ + [.testWidget do {return [lsort [array names itk_component]]}] \ + [.testWidget configure] +} {{hull test1 test2} {{-background background Background linen linen} {-borderwidth borderWidth BorderWidth 2 2} {-clientdata clientData ClientData {} {}} {-command command Command {} {}} {-cursor cursor Cursor {} {}} {-foreground foreground Foreground navy navy} {-highlight highlight Foreground white white} {-normal normal Background ivory ivory} {-status status Status {} {}} {-text text Text {} {}}} 0 {hull test2} {hull test2} {{-background background Background linen linen} {-borderwidth borderWidth BorderWidth 2 2} {-clientdata clientData ClientData {} {}} {-command command Command {} {}} {-cursor cursor Cursor {} {}} {-foreground foreground Foreground navy navy} {-highlight highlight Foreground white white} {-normal normal Background ivory ivory} {-status status Status {} {}}}} + +test widget-1.26 {when an internal component is deleted (but not destroyed) it is disconnected from the option list and its binding tags are updated} { + set comp [.testWidget component test2] + list [bindtags $comp] \ + [bind itk-destroy-$comp ] \ + [catch {.testWidget do {itk_component delete test2}}] \ + [bindtags $comp] \ + [bind itk-destroy-$comp ] \ + [.testWidget configure] +} {{itk-destroy-.testWidget.t2 .testWidget.t2 Button . all} {namespace inscope ::itk::Archetype {::.testWidget itk_component delete test2}} 0 {.testWidget.t2 Button . all} {} {{-background background Background linen linen} {-clientdata clientData ClientData {} {}} {-cursor cursor Cursor {} {}} {-status status Status {} {}}}} + +test widget-1.27 {when a mega-widget object is deleted, its window and any + components are destroyed (even if in another window) } { + itcl::class ButtonWidget { + inherit itk::Widget + + constructor {args} { + eval itk_initialize $args + + itk_component add button { + button $itk_option(-container).b -text Button + } {} + pack $itk_component(button) + } + + itk_option define -container container Container {} + } + + toplevel .t1 + frame .t1.f + ButtonWidget .t1.bw -container .t1.f + + pack .t1.f + pack .t1.bw + + set button [.t1.bw component button] + + itcl::delete object .t1.bw + + set result [list $button [winfo exists $button]] + + itcl::delete class ButtonWidget + + set result +} {.t1.f.b 0} + + # ---------------------------------------------------------------------- # Clean up # ---------------------------------------------------------------------- itcl::delete class TestWidget + +::tcltest::cleanupTests +exit -- 2.11.0