Fixed a memory leak when a placed widget was forgotten. [Bug 1028888]

1 files changed, 45 insertions, 1 deletions

diff --git a/tests/place.test b/tests/place.test
index 847047c..c2a4042 100644
--- a/tests/place.test
+++ b/tests/place.test
@@ -5,12 +5,15 @@
 # Copyright (c) 1998-1999 by Scriptics Corporation.
 # All rights reserved.
 #
-# RCS: @(#) $Id: place.test,v 1.10 2003/04/01 21:06:49 dgp Exp $
+# RCS: @(#) $Id: place.test,v 1.11 2004/09/16 18:01:20 pspjuth Exp $
 
 package require tcltest 2.1
 eval tcltest::configure $argv
 tcltest::loadTestedCommands
 
+# Used for constraining memory leak tests
+testConstraint memory [llength [info commands memory]]
+
 # XXX - This test file is woefully incomplete.  At present, only a
 # few of the features are tested.
 
@@ -380,6 +383,47 @@ test place-13.1 {test respect for internalborder} {
     set res
 } {196x188+2+10 177x186+5+7}
 
+test place-14.1 {memory leak testing} -setup {
+    proc getbytes {} {
+        set lines [split [memory info] "\n"]
+        lindex [lindex $lines 3] 3
+    }
+    # Repeat each body checking that memory does not increase
+    proc stress {args} {
+        set res {}
+        foreach body $args {
+            set end 0
+            for {set i 0} {$i < 5} {incr i} {
+                uplevel 1 $body
+                set tmp $end
+                set end [getbytes]
+            }
+            lappend res [expr {$end - $tmp}]
+        }
+        return $res
+    }
+} -constraints memory -body {
+    # Test all manners of forgetting a slave
+    frame .f
+    frame .f.f
+    stress {
+        place .f.f -x [expr {1 + 1}] -y [expr {2 + 2}]
+        place forget .f.f
+    } {
+        place .f.f -x [expr {1 + 1}] -y [expr {2 + 2}]
+        pack .f.f
+    } {
+        place .f.f -x [expr {1 + 1}] -y [expr {2 + 2}]
+        destroy .f
+        frame .f
+        frame .f.f
+    }
+} -result {0 0 0} -cleanup {
+    destroy .f
+    rename getbytes {}
+    rename stress {}
+}
+
 catch {destroy .t}
 
 # cleanup