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.

diff --git a/itcl/ChangeLog b/itcl/ChangeLog
index 2067966..f9ce998 100644 (file)
--- a/itcl/ChangeLog
+++ b/itcl/ChangeLog
@@ -1,3 +1,16 @@
+2002-02-21  Mo DeJong  <supermo@bayarea.net>
+
+        * 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  <keiths@redhat.com>
 
         * itcl/library/itcl.tcl: Add recognition for "class", "body",

diff --git a/itcl/itk/library/Toplevel.itk b/itcl/itk/library/Toplevel.itk
index cb01a6d..a179622 100644 (file)
--- 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 8c455e3..1474e61 100644 (file)
--- 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 ac6a07f..ed254dd 100644 (file)
--- 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 f793b7d..da91291 100644 (file)
--- 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 <Destroy>] \
+      [catch {.testWidget do {itk_component delete test2}}] \
+         [bindtags $comp] \
+         [bind itk-destroy-$comp <Destroy>] \
+         [.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