if {[info exists tk_version]} {
tk appname tktest
wm title . tktest
} else {
set auto_path [list [info library]]
}
namespace eval tcltest {
set procList [list test cleanupTests dotests saveState restoreState \
normalizeMsg makeFile removeFile makeDirectory removeDirectory \
viewFile bytestring set_iso8859_1_locale restore_locale \
safeFetch threadReap]
if {[info exists tk_version]} {
lappend procList setupbg dobg bgReady cleanupbg fixfocus
}
foreach proc $procList {
namespace export $proc
}
variable verbose "b"
variable match {}
variable skip {}
set originalDir [pwd]
set tDir [file join $originalDir [file dirname [info script]]]
cd $tDir
variable testsDir [pwd]
cd $originalDir
variable numTestFiles 0
variable testSingleFile true
variable currentFailure false
variable failFiles {}
variable filesMade {}
variable filesExisted {}
array set ::tcltest::createdNewFiles {}
array set numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
array set ::tcltest::skippedBecause {}
variable ::tcltest::mainThread 1
if {[info commands testthread] != {}} {
set ::tcltest::mainThread [testthread names]
}
}
if {[info commands memory] == ""} {
proc memory args {}
}
proc ::tcltest::initConfig {} {
global tcl_platform tcl_interactive tk_version
catch {unset ::tcltest::testConfig}
trace variable ::tcltest::testConfig r ::tcltest::safeFetch
proc ::tcltest::safeFetch {n1 n2 op} {
if {($n2 != {}) && ([info exists ::tcltest::testConfig($n2)] == 0)} {
set ::tcltest::testConfig($n2) 0
}
}
set ::tcltest::testConfig(unixOnly) \
[expr {$tcl_platform(platform) == "unix"}]
set ::tcltest::testConfig(macOnly) \
[expr {$tcl_platform(platform) == "macintosh"}]
set ::tcltest::testConfig(pcOnly) \
[expr {$tcl_platform(platform) == "windows"}]
set ::tcltest::testConfig(unix) $::tcltest::testConfig(unixOnly)
set ::tcltest::testConfig(mac) $::tcltest::testConfig(macOnly)
set ::tcltest::testConfig(pc) $::tcltest::testConfig(pcOnly)
set ::tcltest::testConfig(unixOrPc) \
[expr {$::tcltest::testConfig(unix) || $::tcltest::testConfig(pc)}]
set ::tcltest::testConfig(macOrPc) \
[expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(pc)}]
set ::tcltest::testConfig(macOrUnix) \
[expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(unix)}]
set ::tcltest::testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}]
set ::tcltest::testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}]
set ::tcltest::testConfig(tempNotPc) [expr {!$::tcltest::testConfig(pc)}]
set ::tcltest::testConfig(tempNotMac) [expr {!$::tcltest::testConfig(mac)}]
set ::tcltest::testConfig(tempNotUnix) [expr {!$::tcltest::testConfig(unix)}]
set ::tcltest::testConfig(pcCrash) [expr {!$::tcltest::testConfig(pc)}]
set ::tcltest::testConfig(macCrash) [expr {!$::tcltest::testConfig(mac)}]
set ::tcltest::testConfig(unixCrash) [expr {!$::tcltest::testConfig(unix)}]
if {[info exists tk_version]} {
set ::tcltest::testConfig(fonts) 1
catch {destroy .e}
entry .e -width 0 -font {Helvetica -12} -bd 1
.e insert end "a.bcd"
if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
set ::tcltest::testConfig(fonts) 0
}
destroy .e
catch {destroy .t}
text .t -width 80 -height 20 -font {Times -14} -bd 1
pack .t
.t insert end "This is\na dot."
update
set x [list [.t bbox 1.3] [.t bbox 2.5]]
destroy .t
if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} {
set ::tcltest::testConfig(fonts) 0
}
}
set ::tcltest::testConfig(emptyTest) 0
set ::tcltest::testConfig(knownBug) 0
set ::tcltest::testConfig(nonPortable) 0
set ::tcltest::testConfig(userInteraction) 0
set ::tcltest::testConfig(interactive) $tcl_interactive
set ::tcltest::testConfig(root) 0
set ::tcltest::testConfig(notRoot) 1
set user {}
if {$tcl_platform(platform) == "unix"} {
catch {set user [exec whoami]}
if {$user == ""} {
catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
}
if {($user == "root") || ($user == "")} {
set ::tcltest::testConfig(root) 1
set ::tcltest::testConfig(notRoot) 0
}
}
if {[catch {set f [open defs r]}]} {
set ::tcltest::testConfig(nonBlockFiles) 1
} else {
if {[catch {fconfigure $f -blocking off}] == 0} {
set ::tcltest::testConfig(nonBlockFiles) 1
} else {
set ::tcltest::testConfig(nonBlockFiles) 0
}
close $f
}
if {$tcl_platform(platform) == "unix"} {
if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
set ::tcltest::testConfig(asyncPipeClose) 0
} else {
set ::tcltest::testConfig(asyncPipeClose) 1
}
} else {
set ::tcltest::testConfig(asyncPipeClose) 1
}
set ::tcltest::testConfig(eformat) 1
if {[string compare "[format %g 5e-5]" "5e-05"] != 0} {
set ::tcltest::testConfig(eformat) 0
}
set ::tcltest::testConfig(unixExecs) 1
if {$tcl_platform(platform) == "macintosh"} {
set ::tcltest::testConfig(unixExecs) 0
}
if {($::tcltest::testConfig(unixExecs) == 1) && \
($tcl_platform(platform) == "windows")} {
if {[catch {exec cat defs}] == 1} {
set ::tcltest::testConfig(unixExecs) 0
}
if {($::tcltest::testConfig(unixExecs) == 1) && \
([catch {exec echo hello}] == 1)} {
set ::tcltest::testConfig(unixExecs) 0
}
if {($::tcltest::testConfig(unixExecs) == 1) && \
([catch {exec sh -c echo hello}] == 1)} {
set ::tcltest::testConfig(unixExecs) 0
}
if {($::tcltest::testConfig(unixExecs) == 1) && \
([catch {exec wc defs}] == 1)} {
set ::tcltest::testConfig(unixExecs) 0
}
if {$::tcltest::testConfig(unixExecs) == 1} {
exec echo hello > removeMe
if {[catch {exec rm removeMe}] == 1} {
set ::tcltest::testConfig(unixExecs) 0
}
}
if {($::tcltest::testConfig(unixExecs) == 1) && \
([catch {exec sleep 1}] == 1)} {
set ::tcltest::testConfig(unixExecs) 0
}
if {($::tcltest::testConfig(unixExecs) == 1) && \
([catch {exec fgrep unixExecs defs}] == 1)} {
set ::tcltest::testConfig(unixExecs) 0
}
if {($::tcltest::testConfig(unixExecs) == 1) && \
([catch {exec ps}] == 1)} {
set ::tcltest::testConfig(unixExecs) 0
}
if {($::tcltest::testConfig(unixExecs) == 1) && \
([catch {exec echo abc > removeMe}] == 0) && \
([catch {exec chmod 644 removeMe}] == 1) && \
([catch {exec rm removeMe}] == 0)} {
set ::tcltest::testConfig(unixExecs) 0
} else {
catch {exec rm -f removeMe}
}
if {($::tcltest::testConfig(unixExecs) == 1) && \
([catch {exec mkdir removeMe}] == 1)} {
set ::tcltest::testConfig(unixExecs) 0
} else {
catch {exec rm -r removeMe}
}
}
}
::tcltest::initConfig
proc ::tcltest::processCmdLineArgs {} {
global argv
if {(![info exists argv]) || ([llength $argv] < 2)} {
set flagArray {}
} else {
set flagArray $argv
}
if {[catch {array set flag $flagArray}]} {
puts stderr "Error: odd number of command line args specified:"
puts stderr " $argv"
exit
}
foreach arg {-verbose -match -skip -constraints} {
set abbrev [string range $arg 0 1]
if {([info exists flag($abbrev)]) && \
([lsearch -exact $flagArray $arg] < \
[lsearch -exact $flagArray $abbrev])} {
set flag($arg) $flag($abbrev)
}
}
set ::tcltest::workingDir [pwd]
foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] {
lappend ::tcltest::filesExisted [file tail $file]
}
if {[info exists flag(-verbose)]} {
set ::tcltest::verbose $flag(-verbose)
}
if {[info exists flag(-match)]} {
set ::tcltest::match $flag(-match)
}
if {[info exists flag(-skip)]} {
set ::tcltest::skip $flag(-skip)
}
if {[info exists flag(-constraints)]} {
foreach elt $flag(-constraints) {
set ::tcltest::testConfig($elt) 1
}
}
}
::tcltest::processCmdLineArgs
proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
set tail [file tail [info script]]
if {!$calledFromAllFile} {
foreach file $::tcltest::filesMade {
if {[file exists $file]} {
catch {file delete -force $file}
}
}
set currentFiles {}
foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] {
lappend currentFiles [file tail $file]
}
set newFiles {}
foreach file $currentFiles {
if {[lsearch -exact $::tcltest::filesExisted $file] == -1} {
lappend newFiles $file
}
}
set ::tcltest::filesExisted $currentFiles
if {[llength $newFiles] > 0} {
set ::tcltest::createdNewFiles($tail) $newFiles
}
}
if {$calledFromAllFile || $::tcltest::testSingleFile} {
puts -nonewline stdout "$tail:"
foreach index [list "Total" "Passed" "Skipped" "Failed"] {
puts -nonewline stdout "\t$index\t$::tcltest::numTests($index)"
}
puts stdout ""
if {$calledFromAllFile} {
puts stdout "Sourced $::tcltest::numTestFiles Test Files."
set ::tcltest::numTestFiles 0
if {[llength $::tcltest::failFiles] > 0} {
puts stdout "Files with failing tests: $::tcltest::failFiles"
set ::tcltest::failFiles {}
}
}
set constraintList [array names ::tcltest::skippedBecause]
if {[llength $constraintList] > 0} {
puts stdout "Number of tests skipped for each constraint:"
foreach constraint [lsort $constraintList] {
puts stdout \
"\t$::tcltest::skippedBecause($constraint)\t$constraint"
unset ::tcltest::skippedBecause($constraint)
}
}
set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]]
if {[llength $testFilesThatTurded] > 0} {
puts stdout "Warning: test files left files behind:"
foreach testFile $testFilesThatTurded {
puts "\t$testFile:\t$::tcltest::createdNewFiles($testFile)"
unset ::tcltest::createdNewFiles($testFile)
}
}
set ::tcltest::filesMade {}
foreach index [list "Total" "Passed" "Skipped" "Failed"] {
set ::tcltest::numTests($index) 0
}
global tk_version tcl_interactive
if {[info exists tk_version] && !$tcl_interactive} {
exit
}
} else {
incr ::tcltest::numTestFiles
if {($::tcltest::currentFailure) && \
([lsearch -exact $::tcltest::failFiles $tail] == -1)} {
lappend ::tcltest::failFiles $tail
}
set ::tcltest::currentFailure false
}
}
proc ::tcltest::test {name description script expectedAnswer args} {
incr ::tcltest::numTests(Total)
foreach pattern $::tcltest::skip {
if {[string match $pattern $name]} {
incr ::tcltest::numTests(Skipped)
return
}
}
if {[llength $::tcltest::match] > 0} {
set ok 0
foreach pattern $::tcltest::match {
if {[string match $pattern $name]} {
set ok 1
break
}
}
if {!$ok} {
incr ::tcltest::numTests(Skipped)
return
}
}
set i [llength $args]
if {$i == 0} {
set constraints {}
} elseif {$i == 1} {
set constraints $script
set script $expectedAnswer
set expectedAnswer [lindex $args 0]
set doTest 0
if {[string match {*[$\[]*} $constraints] != 0} {
catch {set doTest [uplevel
} elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
regsub -all {[.a-zA-Z0-9]+} $constraints \
{$::tcltest::testConfig(&)} c
catch {set doTest [eval expr $c]}
} else {
set doTest 1
foreach constraint $constraints {
if {![info exists ::tcltest::testConfig($constraint)]
|| !$::tcltest::testConfig($constraint)} {
set doTest 0
set constraints $constraint
break
}
}
}
if {$doTest == 0} {
incr ::tcltest::numTests(Skipped)
if {[string first s $::tcltest::verbose] != -1} {
puts stdout "++++ $name SKIPPED: $constraints"
}
if {[info exists ::tcltest::skippedBecause($constraints)]} {
incr ::tcltest::skippedBecause($constraints)
} else {
set ::tcltest::skippedBecause($constraints) 1
}
return
}
} else {
error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
}
memory tag $name
set code [catch {uplevel $script} actualAnswer]
if {$code != 0 || [string compare $actualAnswer $expectedAnswer] != 0} {
incr ::tcltest::numTests(Failed)
set ::tcltest::currentFailure true
if {[string first b $::tcltest::verbose] == -1} {
set script ""
}
puts stdout "\n==== $name $description FAILED"
if {$script != ""} {
puts stdout "==== Contents of test case:"
puts stdout $script
}
if {$code != 0} {
if {$code == 1} {
puts stdout "==== Test generated error:"
puts stdout $actualAnswer
} elseif {$code == 2} {
puts stdout "==== Test generated return exception; result was:"
puts stdout $actualAnswer
} elseif {$code == 3} {
puts stdout "==== Test generated break exception"
} elseif {$code == 4} {
puts stdout "==== Test generated continue exception"
} else {
puts stdout "==== Test generated exception $code; message was:"
puts stdout $actualAnswer
}
} else {
puts stdout "---- Result was:\n$actualAnswer"
}
puts stdout "---- Result should have been:\n$expectedAnswer"
puts stdout "==== $name FAILED\n"
} else {
incr ::tcltest::numTests(Passed)
if {[string first p $::tcltest::verbose] != -1} {
puts stdout "++++ $name PASSED"
}
}
}
proc ::tcltest::dotests {file args} {
set savedTests $::tcltest::match
set ::tcltest::match $args
source $file
set ::tcltest::match $savedTests
}
proc ::tcltest::openfiles {} {
if {[catch {testchannel open} result]} {
return {}
}
return $result
}
proc ::tcltest::leakfiles {old} {
if {[catch {testchannel open} new]} {
return {}
}
set leak {}
foreach p $new {
if {[lsearch $old $p] < 0} {
lappend leak $p
}
}
return $leak
}
set ::tcltest::saveState {}
proc ::tcltest::saveState {} {
uplevel }
proc ::tcltest::restoreState {} {
foreach p [info procs] {
if {[lsearch [lindex $::tcltest::saveState 0] $p] < 0} {
rename $p {}
}
}
foreach p [uplevel if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
uplevel }
}
}
proc ::tcltest::normalizeMsg {msg} {
regsub "\n$" [string tolower $msg] "" msg
regsub -all "\n\n" $msg "\n" msg
regsub -all "\n\}" $msg "\}" msg
return $msg
}
proc ::tcltest::makeFile {contents name} {
set fd [open $name w]
fconfigure $fd -translation lf
if {[string index $contents [expr {[string length $contents] - 1}]] == "\n"} {
puts -nonewline $fd $contents
} else {
puts $fd $contents
}
close $fd
set fullName [file join [pwd] $name]
if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
lappend ::tcltest::filesMade $fullName
}
}
proc ::tcltest::removeFile {name} {
file delete $name
}
proc ::tcltest::makeDirectory {name} {
file mkdir $name
set fullName [file join [pwd] $name]
if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
lappend ::tcltest::filesMade $fullName
}
}
proc ::tcltest::removeDirectory {name} {
file delete -force $name
}
proc ::tcltest::viewFile {name} {
global tcl_platform
if {($tcl_platform(platform) == "macintosh") || \
($::tcltest::testConfig(unixExecs) == 0)} {
set f [open $name]
set data [read -nonewline $f]
close $f
return $data
} else {
exec cat $name
}
}
proc ::tcltest::bytestring {string} {
encoding convertfrom identity $string
}
if {![info exists tk_version]} {
set tcltest [info nameofexecutable]
if {$tcltest == "{}"} {
set tcltest {}
}
}
set ::tcltest::testConfig(stdio) 0
catch {
catch {file delete -force tmp}
set f [open tmp w]
puts $f {
exit
}
close $f
set f [open "|[list $tcltest tmp]" r]
close $f
set ::tcltest::testConfig(stdio) 1
}
catch {file delete -force tmp}
catch {socket} msg
set ::tcltest::testConfig(socket) \
[expr {$msg != "sockets are not available on this system"}]
if {[info commands testlocale]==""} {
set ::tcltest::testConfig(hasIsoLocale) 0
} else {
proc ::tcltest::set_iso8859_1_locale {} {
set ::tcltest::previousLocale [testlocale ctype]
testlocale ctype $::tcltest::isoLocale
}
proc ::tcltest::restore_locale {} {
testlocale ctype $::tcltest::previousLocale
}
if {![info exists ::tcltest::isoLocale]} {
set ::tcltest::isoLocale fr
switch $tcl_platform(platform) {
"unix" {
switch -exact -- $tcl_platform(os) {
"FreeBSD" {
set ::tcltest::isoLocale fr_FR.ISO_8859-1
}
HP-UX {
set ::tcltest::isoLocale fr_FR.iso88591
}
Linux -
IRIX {
set ::tcltest::isoLocale fr
}
default {
set ::tcltest::isoLocale iso_8859_1
}
}
}
"windows" {
set ::tcltest::isoLocale French
}
}
}
set ::tcltest::testConfig(hasIsoLocale) \
[string length [::tcltest::set_iso8859_1_locale]]
::tcltest::restore_locale
}
if {[info exists tk_version]} {
if {![winfo ismapped .]} {
wm geometry . +0+0
update
}
set ::tcltest::tktest [info nameofexecutable]
if {$::tcltest::tktest == "{}"} {
set ::tcltest::tktest {}
puts stdout \
"Unable to find tktest executable, skipping multiple process tests."
}
proc ::tcltest::setupbg args {
if {$::tcltest::tktest == ""} {
error "you're not running tktest so setupbg should not have been called"
}
if {[info exists ::tcltest::fd] && ($::tcltest::fd != "")} {
cleanupbg
}
global tcl_platform
if {$tcl_platform(platform) != "windows"} {
set ::tcltest::fd [open "|[list $::tcltest::tktest -geometry +0+0 -name tktest] $args" r+]
puts $::tcltest::fd "puts foo; flush stdout"
flush $::tcltest::fd
if {[gets $::tcltest::fd data] < 0} {
error "unexpected EOF from \"$::tcltest::tktest\""
}
if {[string compare $data foo]} {
error "unexpected output from background process \"$data\""
}
fileevent $::tcltest::fd readable bgReady
}
}
proc ::tcltest::dobg {command} {
puts $::tcltest::fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout"
flush $::tcltest::fd
set ::tcltest::bgDone 0
set ::tcltest::bgData {}
tkwait variable ::tcltest::bgDone
set ::tcltest::bgData
}
proc ::tcltest::bgReady {} {
set x [gets $::tcltest::fd]
if {[eof $::tcltest::fd]} {
fileevent $::tcltest::fd readable {}
set ::tcltest::bgDone 1
} elseif {$x == "**DONE**"} {
set ::tcltest::bgDone 1
} else {
append ::tcltest::bgData $x
}
}
proc ::tcltest::cleanupbg {} {
catch {
puts $::tcltest::fd "exit"
close $::tcltest::fd
}
set ::tcltest::fd ""
}
proc ::tcltest::fixfocus {} {
catch {destroy .focus}
toplevel .focus
wm geometry .focus +0+0
entry .focus.e
.focus.e insert 0 "fixfocus"
pack .focus.e
update
focus -force .focus.e
destroy .focus
}
}
if {[info commands testthread] != {}} {
proc ::tcltest::threadReap {} {
testthread errorproc ThreadNullError
while {[llength [testthread names]] > 1} {
foreach tid [testthread names] {
if {$tid != $::tcltest::mainThread} {
catch {testthread send -async $tid {testthread exit}}
update
}
}
}
testthread errorproc ThreadError
return [llength [testthread names]]
}
} else {
proc ::tcltest::threadReap {} {
return 1
}
}
catch {namespace import ::tcltest::*}
return