#! /bin/env tclsh
proc init {} {
uplevel 1 {
namespace import ::tcltest::*
::tcltest::configure {*}$::argv
set bgerror [interp bgerror {}]
if {$bgerror in {{} {::tcl::Bgerror}}} {
interp bgerror {} [list apply {{res opts} {
puts stderr [dict get $opts -errorinfo]
exit 1
}}]
}
testConstraint coroutine [expr {[namespace which ::coroutine] ne {}}]
}
}
proc main {argv0 argv script} {
set var [namespace current]::[info cmdcount]
after 0 [list ::coroutine [uplevel 1 {namespace current}]::main apply [
list {var argv0 argv script} {
catch $script res options
if {[dict exists $options -errorinfo]} {
puts stderr [dict get $options -errorinfo]
}
set $var [dict get $options -code]
} [uplevel 1 {namespace current}]] $var $argv0 $argv $script]
vwait $var
exit [set $var]
}
proc runtests {{startdir {}}} {
if {$startdir eq {}} {
set startdir [pwd]
}
global argv
::tcltest::configure {*}$argv -testdir $startdir
namespace eval :: {
set ::env(TCLLIBPATH) $auto_path
tcltest::configure -testdir [pwd]
tcltest::runAllTests
}
}
proc body script {
set body {
set res [list]
$script
return $res
}
set res [string map [list \$script $script] $body]
return $res
}
proc cleanup1 {} {
set ns [uplevel 1 {namespace current}]
set commands [lmap x [info commands ${ns}::*] {
namespace tail $x
}]
set localvars [uplevel 1 {info locals}]
set nsvars {}
foreach var [info vars ${ns}::*] {
if {[info exists $var]} {
lappend nsvars [namespace tail $var]
}
}
set namespaces [uplevel 1 {namespace children}]
set bgres {}
set bgopts {}
set res {}
list ::apply {{ns commands namespaces nsvars localvars} {
foreach localvar [uplevel 1 {info locals}] {
if {$localvar ni $localvars} {
uplevel 1 [list ::unset $localvar]
}
}
foreach varname [info vars ${ns}::*] {
set tail [namespace tail $varname]
if {$tail ni $nsvars} {
puts [list unsetting $varname]
unset $varname
}
}
foreach name [info commands ${ns}::*] {
set tail [namespace tail $name]
if {$tail ni $commands} {
if {[namespace which $name] ne {}} {
rename $name {}
}
}
}
foreach name [namespace children $ns *] {
if {$name ni $namespaces} {
if {namespace exists $name} {
namespace delete $name
}
}
}
}} $ns $commands $namespaces $nsvars $localvars
}
variable ::tcltestfailed
if {![info exists tcltestfailed]} {
set tcltestfailed 0
}
namespace eval ::tcltest {
proc cleanupTestsHook {} {
variable numTests
#workaround RunAllTests not exposing crash data
upvar 2 testFileFailures crashed
incr ::tcltestfailed $::tcltest::numTests(Failed)
if {[info exists crashed] && ! $::tcltestfailed} {
incr ::tcltestfailed
}
}
}
package require Tcl 8.5-
package require tcltest 2.2
namespace import ::tcltest::*