Import Tcl 8.6.12

pkgs/itcl4.2.2/tests/helpers.tcl

@@ -0,0 +1,48 @@
+# helpers.tcl --
+#
+# This file contains helper scripts for all tests, like a mem-leak checker, etc.
+
+# -loadfile overwrites -load, so restore it from ::env(TESTFLAGS):
+if {[info exists ::env(TESTFLAGS)]} {
+  array set testargs $::env(TESTFLAGS)
+  if {[info exists ::testargs(-load)]} {
+    eval $::testargs(-load)
+  }
+  unset testargs
+}
+
+package require itcl
+
+if {[namespace which -command memory] ne "" && (
+    ![info exists ::tcl::inl_mem_test] || $::tcl::inl_mem_test
+  )
+} {
+  proc getbytes {} {lindex [split [memory info] \n] 3 3}
+  proc leaktest {script {iterations 3}} {
+      set end [getbytes]
+      for {set i 0} {$i < $iterations} {incr i} {
+          uplevel 1 $script
+          set tmp $end
+          set end [getbytes]
+      }
+      return [expr {$end - $tmp}]
+  }
+  proc itcl_leaktest {testfile} {
+    set leak [leaktest [string map [list \
+      @test@ $testfile \
+      @testargv@ [if {[info exists ::argv]} {list tcltest::configure {*}$::argv}]
+    ] {
+      interp create i
+      load {} Itcl i
+      i eval {set ::tcl::inl_mem_test 0}
+      i eval {package require tcltest; @testargv@}
+      i eval [list source @test@]
+      interp delete i
+    }]]
+    if {$leak} {
+      puts "LEAKED: $leak bytes"
+    }
+  }
+  itcl_leaktest [info script]
+  return -code return
+}