package provide tcltest 1.0
namespace eval tcltest {
set procList [list test cleanupTests saveState restoreState \
normalizeMsg makeFile removeFile makeDirectory removeDirectory \
viewFile bytestring safeFetch threadReap getMatchingFiles \
loadTestedCommands normalizePath]
foreach proc $procList {
namespace export $proc
}
if {![info exists verbose]} {
variable verbose "b"
}
if {![info exists match]} {
variable match {}
}
if {![info exists skip]} {
variable skip {}
}
if {![info exists matchFiles]} {
variable matchFiles {*.test}
}
if {![info exists skipFiles]} {
variable skipFiles {}
}
if {![info exists preserveCore]} {
variable preserveCore 0
}
if {![info exists outputChannel]} {
variable outputChannel stdout
}
if {![info exists errorChannel]} {
variable errorChannel stderr
}
if {![info exists debug]} {
variable debug 0
}
if {![info exists parameters]} {
variable parameters {}
}
if {![info exists numTestFiles]} {
variable numTestFiles 0
}
if {![info exists testSingleFile]} {
variable testSingleFile true
}
if {![info exists currentFailure]} {
variable currentFailure false
}
if {![info exists failFiles]} {
variable failFiles {}
}
if {![info exists filesMade]} {
variable filesMade {}
}
if {![info exists filesExisted]} {
variable filesExisted {}
}
if {![info exists createdNewFiles]} {
variable createdNewFiles
array set ::tcltest::createdNewFiles {}
}
if {![info exists numTests]} {
variable numTests
array set ::tcltest::numTests \
[list Total 0 Passed 0 Skipped 0 Failed 0]
}
if {![info exists skippedBecause]} {
variable skippedBecause
array set ::tcltest::skippedBecause {}
}
if {![info exists testConstraints]} {
variable testConstraints
array set ::tcltest::testConstraints {}
}
if {![info exists limitConstraints]} {
variable limitConstraints false
}
if {![info exists loadScript]} {
variable loadScript {}
}
if {![info exists mainThread]} {
variable mainThread 1
if {[info commands thread::id] != {}} {
set mainThread [thread::id]
} elseif {[info commands testthread] != {}} {
set mainThread [testthread id]
}
}
if {![info exists originalEnv]} {
variable originalEnv
array set ::tcltest::originalEnv [array get ::env]
}
if {![info exists workingDirectory]} {
variable workingDirectory [pwd]
}
if {![info exists temporaryDirectory]} {
variable temporaryDirectory $workingDirectory
}
if {![info exists testsDirectory]} {
set oldpwd [pwd]
catch {cd [file join [file dirname [info script]] .. .. tests]}
variable testsDirectory [pwd]
cd $oldpwd
unset oldpwd
}
if {![info exists saveState]} {
variable saveState {}
}
if {![info exists isoLocale]} {
variable 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
}
}
}
if {![info exists tcltest]} {
variable tcltest [info nameofexecutable]
}
if {![info exists originalTclPlatform]} {
variable originalTclPlatform [array get tcl_platform]
}
if {![info exists coreModificationTime]} {
if {[file exists [file join $::tcltest::workingDirectory core]]} {
variable coreModificationTime [file mtime [file join \
$::tcltest::workingDirectory core]]
}
}
if {![info exists version]} {
variable version 8.3
}
if {![info exists patchLevel]} {
variable patchLevel 8.3.0
}
}
proc ::tcltest::DebugPuts {level string} {
variable debug
if {$debug >= $level} {
puts $string
}
}
proc ::tcltest::DebugPArray {level arrayvar} {
variable debug
if {$debug >= $level} {
catch {upvar $arrayvar $arrayvar}
parray $arrayvar
}
}
proc ::tcltest::DebugDo {level script} {
variable debug
if {$debug >= $level} {
uplevel $script
}
}
proc ::tcltest::AddToSkippedBecause { constraint } {
if {[info exists ::tcltest::skippedBecause($constraint)]} {
incr ::tcltest::skippedBecause($constraint)
} else {
set ::tcltest::skippedBecause($constraint) 1
}
return
}
proc ::tcltest::PrintError {errorMsg} {
set InitialMessage "Error: "
set InitialMsgLen [string length $InitialMessage]
puts -nonewline $::tcltest::errorChannel $InitialMessage
set endingIndex [string length $errorMsg]
if {$endingIndex < 80} {
puts $::tcltest::errorChannel $errorMsg
} else {
set beginningIndex [string last " " [string range $errorMsg 0 \
[expr {80 - $InitialMsgLen}]]]
puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex]
while {$beginningIndex != "end"} {
puts -nonewline $::tcltest::errorChannel \
[string repeat " " $InitialMsgLen]
if {[expr {$endingIndex - $beginningIndex}] < 72} {
puts $::tcltest::errorChannel [string trim \
[string range $errorMsg $beginningIndex end]]
set beginningIndex end
} else {
set newEndingIndex [expr [string last " " [string range \
$errorMsg $beginningIndex \
[expr {$beginningIndex + 72}]]] + $beginningIndex]
if {($newEndingIndex <= 0) \
|| ($newEndingIndex <= $beginningIndex)} {
set newEndingIndex end
}
puts $::tcltest::errorChannel [string trim \
[string range $errorMsg \
$beginningIndex $newEndingIndex]]
set beginningIndex $newEndingIndex
}
}
}
flush $::tcltest::errorChannel
return
}
if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} {
proc ::tcltest::initConstraintsHook {} {}
}
proc ::tcltest::initConstraints {} {
global tcl_platform tcl_interactive tk_version
trace variable ::tcltest::testConstraints r ::tcltest::safeFetch
proc ::tcltest::safeFetch {n1 n2 op} {
if {($n2 != {}) && ([info exists ::tcltest::testConstraints($n2)] == 0)} {
set ::tcltest::testConstraints($n2) 0
}
}
::tcltest::initConstraintsHook
set ::tcltest::testConstraints(unixOnly) \
[string equal $tcl_platform(platform) "unix"]
set ::tcltest::testConstraints(macOnly) \
[string equal $tcl_platform(platform) "macintosh"]
set ::tcltest::testConstraints(pcOnly) \
[string equal $tcl_platform(platform) "windows"]
set ::tcltest::testConstraints(unix) $::tcltest::testConstraints(unixOnly)
set ::tcltest::testConstraints(mac) $::tcltest::testConstraints(macOnly)
set ::tcltest::testConstraints(pc) $::tcltest::testConstraints(pcOnly)
set ::tcltest::testConstraints(unixOrPc) \
[expr {$::tcltest::testConstraints(unix) \
|| $::tcltest::testConstraints(pc)}]
set ::tcltest::testConstraints(macOrPc) \
[expr {$::tcltest::testConstraints(mac) \
|| $::tcltest::testConstraints(pc)}]
set ::tcltest::testConstraints(macOrUnix) \
[expr {$::tcltest::testConstraints(mac) \
|| $::tcltest::testConstraints(unix)}]
set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) \
"Windows NT"]
set ::tcltest::testConstraints(95) [string equal $tcl_platform(os) \
"Windows 95"]
set ::tcltest::testConstraints(98) [string equal $tcl_platform(os) \
"Windows 98"]
set ::tcltest::testConstraints(tempNotPc) \
[expr {!$::tcltest::testConstraints(pc)}]
set ::tcltest::testConstraints(tempNotMac) \
[expr {!$::tcltest::testConstraints(mac)}]
set ::tcltest::testConstraints(tempNotUnix) \
[expr {!$::tcltest::testConstraints(unix)}]
set ::tcltest::testConstraints(pcCrash) \
[expr {!$::tcltest::testConstraints(pc)}]
set ::tcltest::testConstraints(macCrash) \
[expr {!$::tcltest::testConstraints(mac)}]
set ::tcltest::testConstraints(unixCrash) \
[expr {!$::tcltest::testConstraints(unix)}]
set ::tcltest::testConstraints(emptyTest) 0
set ::tcltest::testConstraints(knownBug) 0
set ::tcltest::testConstraints(nonPortable) 0
set ::tcltest::testConstraints(userInteraction) 0
if {[info exists tcl_interactive]} {
set ::tcltest::testConstraints(interactive) $::tcl_interactive
} else {
set ::tcltest::testConstraints(interactive) 0
}
set ::tcltest::testConstraints(root) 0
set ::tcltest::testConstraints(notRoot) 1
set user {}
if {[string equal $tcl_platform(platform) "unix"]} {
catch {set user [exec whoami]}
if {[string equal $user ""]} {
catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
}
if {([string equal $user "root"]) || ([string equal $user ""])} {
set ::tcltest::testConstraints(root) 1
set ::tcltest::testConstraints(notRoot) 0
}
}
if {[catch {set f [open defs r]}]} {
set ::tcltest::testConstraints(nonBlockFiles) 1
} else {
if {[catch {fconfigure $f -blocking off}] == 0} {
set ::tcltest::testConstraints(nonBlockFiles) 1
} else {
set ::tcltest::testConstraints(nonBlockFiles) 0
}
close $f
}
if {[string equal $tcl_platform(platform) "unix"]} {
if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
set ::tcltest::testConstraints(asyncPipeClose) 0
} else {
set ::tcltest::testConstraints(asyncPipeClose) 1
}
} else {
set ::tcltest::testConstraints(asyncPipeClose) 1
}
set ::tcltest::testConstraints(eformat) 1
if {![string equal "[format %g 5e-5]" "5e-05"]} {
set ::tcltest::testConstraints(eformat) 0
}
set ::tcltest::testConstraints(unixExecs) 1
if {[string equal $tcl_platform(platform) "macintosh"]} {
set ::tcltest::testConstraints(unixExecs) 0
}
if {($::tcltest::testConstraints(unixExecs) == 1) && \
([string equal $tcl_platform(platform) "windows"])} {
if {[catch {exec cat defs}] == 1} {
set ::tcltest::testConstraints(unixExecs) 0
}
if {($::tcltest::testConstraints(unixExecs) == 1) && \
([catch {exec echo hello}] == 1)} {
set ::tcltest::testConstraints(unixExecs) 0
}
if {($::tcltest::testConstraints(unixExecs) == 1) && \
([catch {exec sh -c echo hello}] == 1)} {
set ::tcltest::testConstraints(unixExecs) 0
}
if {($::tcltest::testConstraints(unixExecs) == 1) && \
([catch {exec wc defs}] == 1)} {
set ::tcltest::testConstraints(unixExecs) 0
}
if {$::tcltest::testConstraints(unixExecs) == 1} {
exec echo hello > removeMe
if {[catch {exec rm removeMe}] == 1} {
set ::tcltest::testConstraints(unixExecs) 0
}
}
if {($::tcltest::testConstraints(unixExecs) == 1) && \
([catch {exec sleep 1}] == 1)} {
set ::tcltest::testConstraints(unixExecs) 0
}
if {($::tcltest::testConstraints(unixExecs) == 1) && \
([catch {exec fgrep unixExecs defs}] == 1)} {
set ::tcltest::testConstraints(unixExecs) 0
}
if {($::tcltest::testConstraints(unixExecs) == 1) && \
([catch {exec ps}] == 1)} {
set ::tcltest::testConstraints(unixExecs) 0
}
if {($::tcltest::testConstraints(unixExecs) == 1) && \
([catch {exec echo abc > removeMe}] == 0) && \
([catch {exec chmod 644 removeMe}] == 1) && \
([catch {exec rm removeMe}] == 0)} {
set ::tcltest::testConstraints(unixExecs) 0
} else {
catch {exec rm -f removeMe}
}
if {($::tcltest::testConstraints(unixExecs) == 1) && \
([catch {exec mkdir removeMe}] == 1)} {
set ::tcltest::testConstraints(unixExecs) 0
} else {
catch {exec rm -r removeMe}
}
}
if {![info exists tk_version]} {
set tcltest [info nameofexecutable]
if {$tcltest == "{}"} {
set tcltest {}
}
}
set ::tcltest::testConstraints(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::testConstraints(stdio) 1
}
catch {file delete -force tmp}
catch {socket} msg
set ::tcltest::testConstraints(socket) \
[expr {$msg != "sockets are not available on this system"}]
if {[info commands testlocale] == ""} {
set ::tcltest::testConstraints(hasIsoLocale) 0
} else {
set ::tcltest::testConstraints(hasIsoLocale) \
[string length [::tcltest::set_iso8859_1_locale]]
::tcltest::restore_locale
}
}
if {[namespace inscope ::tcltest info procs PrintUsageInfoHook] == {}} {
proc ::tcltest::PrintUsageInfoHook {} {}
}
proc ::tcltest::PrintUsageInfo {} {
puts [format "Usage: [file tail [info nameofexecutable]] \
script ?-help? ?flag value? ... \n\
Available flags (and valid input values) are: \n\
-help \t Display this usage information. \n\
-verbose level \t Takes any combination of the values \n\
\t 'p', 's' and 'b'. Test suite will \n\
\t display all passed tests if 'p' is \n\
\t specified, all skipped tests if 's' \n\
\t is specified, and the bodies of \n\
\t failed tests if 'b' is specified. \n\
\t The default value is 'b'. \n\
-constraints list\t Do not skip the listed constraints\n\
-limitconstraints bool\t Only run tests with the constraints\n\
\t listed in -constraints.\n\
-match pattern \t Run all tests within the specified \n\
\t files that match the glob pattern \n\
\t given. \n\
-skip pattern \t Skip all tests within the set of \n\
\t specified tests (via -match) and \n\
\t files that match the glob pattern \n\
\t given. \n\
-file pattern \t Run tests in all test files that \n\
\t match the glob pattern given. \n\
-notfile pattern\t Skip all test files that match the \n\
\t glob pattern given. \n\
-preservecore level \t If 2, save any core files produced \n\
\t during testing in the directory \n\
\t specified by -tmpdir. If 1, notify the\n\
\t user if core files are created. The default \n\
\t is $::tcltest::preserveCore. \n\
-tmpdir directory\t Save temporary files in the specified\n\
\t directory. The default value is \n\
\t $::tcltest::temporaryDirectory. \n\
-testdir directories\t Search tests in the specified\n\
\t directories. The default value is \n\
\t $::tcltest::testsDirectory. \n\
-outfile file \t Send output from test runs to the \n\
\t specified file. The default is \n\
\t stdout. \n\
-errfile file \t Send errors from test runs to the \n\
\t specified file. The default is \n\
\t stderr. \n\
-loadfile file \t Read the script to load the tested \n\
\t commands from the specified file. \n\
-load script \t Specifies the script to load the tested \n\
\t commands. \n\
-debug level \t Internal debug flag."]
::tcltest::PrintUsageInfoHook
return
}
proc ::tcltest::CheckDirectory {rw dir errMsg} {
if {![file isdir $dir]} {
::tcltest::PrintError "$errMsg \"$dir\" is not a directory"
exit 1
} elseif {([string first w $rw] >= 0) && ![file writable $dir]} {
::tcltest::PrintError "$errMsg \"$dir\" is not writeable"
exit 1
} elseif {([string first r $rw] >= 0) && ![file readable $dir]} {
::tcltest::PrintError "$errMsg \"$dir\" is not readable"
exit 1
}
}
proc ::tcltest::normalizePath {pathVar} {
upvar $pathVar path
set oldpwd [pwd]
catch {cd $path}
set path [pwd]
cd $oldpwd
}
proc ::tcltest::MakeAbsolutePath {pathVar {prefix {}}} {
upvar $pathVar path
if {![string equal [file pathtype $path] "absolute"]} {
if {$prefix == {}} {
set prefix [pwd]
}
set path [file join $prefix $path]
}
}
if {[namespace inscope ::tcltest info procs processCmdLineArgsAddFlagsHook] == {}} {
proc ::tcltest::processCmdLineArgsAddFlagsHook {} {}
}
if {[namespace inscope ::tcltest info procs processCmdLineArgsHook] == {}} {
proc ::tcltest::processCmdLineArgsHook {flag} {}
}
proc ::tcltest::processCmdLineArgs {} {
global argv
if {(![info exists argv]) || ([llength $argv] < 1)} {
set flagArray {}
} else {
set flagArray $argv
}
if {([lsearch -exact $flagArray {-help}] != -1) || \
([lsearch -exact $flagArray {-h}] != -1)} {
::tcltest::PrintUsageInfo
exit 1
}
if {[catch {array set flag $flagArray}]} {
::tcltest::PrintError "odd number of arguments specified on command line: \
$argv"
::tcltest::PrintUsageInfo
exit 1
}
lappend defaultFlags -verbose -match -skip -constraints \
-outfile -errfile -debug -tmpdir -file -notfile \
-preservecore -limitconstraints -args -testdir \
-load -loadfile
set defaultFlags [concat $defaultFlags \
[ ::tcltest::processCmdLineArgsAddFlagsHook ]]
foreach arg $defaultFlags {
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)
}
}
if {[info exists flag(-args)]} {
set ::tcltest::parameters $flag(-args)
}
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(-file)]} {
set ::tcltest::matchFiles $flag(-file)
}
if {[info exists flag(-notfile)]} {
set ::tcltest::skipFiles $flag(-notfile)
}
if {[info exists flag(-constraints)]} {
foreach elt $flag(-constraints) {
set ::tcltest::testConstraints($elt) 1
}
}
if {[info exists flag(-limitconstraints)]} {
if {![info exists flag(-constraints)]} {
puts "You can only use the -limitconstraints flag with \
-constraints"
exit 1
}
set ::tcltest::limitConstraints $flag(-limitconstraints)
foreach elt [array names ::tcltest::testConstraints] {
if {[lsearch -exact $flag(-constraints) $elt] == -1} {
set ::tcltest::testConstraints($elt) 0
}
}
}
set tmpDirError ""
if {[info exists flag(-tmpdir)]} {
set ::tcltest::temporaryDirectory $flag(-tmpdir)
MakeAbsolutePath ::tcltest::temporaryDirectory
set tmpDirError "bad argument \"$flag(-tmpdir)\" to -tmpdir: "
}
if {[file exists $::tcltest::temporaryDirectory]} {
::tcltest::CheckDirectory rw $::tcltest::temporaryDirectory $tmpDirError
} else {
file mkdir $::tcltest::temporaryDirectory
}
normalizePath ::tcltest::temporaryDirectory
set testDirError ""
if {[info exists flag(-testdir)]} {
set ::tcltest::testsDirectory $flag(-testdir)
MakeAbsolutePath ::tcltest::testsDirectory
set testDirError "bad argument \"$flag(-testdir)\" to -testdir: "
}
if {[file exists $::tcltest::testsDirectory]} {
::tcltest::CheckDirectory r $::tcltest::testsDirectory $testDirError
} else {
::tcltest::PrintError "$testDirError \"$::tcltest::testsDirectory\" \
does not exist"
exit 1
}
normalizePath ::tcltest::testsDirectory
foreach file [glob -nocomplain \
[file join $::tcltest::temporaryDirectory *]] {
lappend ::tcltest::filesExisted [file tail $file]
}
if {[info exists flag(-outfile)]} {
set tmp $flag(-outfile)
MakeAbsolutePath tmp $::tcltest::temporaryDirectory
set ::tcltest::outputChannel [open $tmp w]
}
if {[info exists flag(-errfile)]} {
set tmp $flag(-errfile)
MakeAbsolutePath tmp $::tcltest::temporaryDirectory
set ::tcltest::errorChannel [open $tmp w]
}
if {[info exists flag(-load)] && \
([lsearch -exact $flagArray -load] > \
[lsearch -exact $flagArray -loadfile])} {
set ::tcltest::loadScript $flag(-load)
}
if {[info exists flag(-loadfile)] && \
([lsearch -exact $flagArray -loadfile] > \
[lsearch -exact $flagArray -load]) } {
set tmp $flag(-loadfile)
MakeAbsolutePath tmp $::tcltest::temporaryDirectory
set tmp [open $tmp r]
set ::tcltest::loadScript [read $tmp]
close $tmp
}
if {[info exists flag(-debug)]} {
set ::tcltest::debug $flag(-debug)
}
if {[info exists flag(-preservecore)]} {
set ::tcltest::preserveCore $flag(-preservecore)
}
::tcltest::processCmdLineArgsHook [array get flag]
DebugPuts 2 "Flags passed into tcltest:"
DebugPArray 2 flag
DebugPuts 2 "::tcltest::debug = $::tcltest::debug"
DebugPuts 2 "::tcltest::testsDirectory = $::tcltest::testsDirectory"
DebugPuts 2 "::tcltest::workingDirectory = $::tcltest::workingDirectory"
DebugPuts 2 "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory"
DebugPuts 2 "::tcltest::outputChannel = $::tcltest::outputChannel"
DebugPuts 2 "::tcltest::errorChannel = $::tcltest::errorChannel"
DebugPuts 2 "Original environment (::tcltest::originalEnv):"
DebugPArray 2 ::tcltest::originalEnv
DebugPuts 2 "Constraints:"
DebugPArray 2 ::tcltest::testConstraints
}
proc ::tcltest::loadTestedCommands {} {
if {$::tcltest::loadScript == {}} {
return
}
uplevel }
proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
set testFileName [file tail [info script]]
::tcltest::cleanupTestsHook
if {!$calledFromAllFile} {
foreach file $::tcltest::filesMade {
if {[file exists $file]} {
catch {file delete -force $file}
}
}
set currentFiles {}
foreach file [glob -nocomplain \
[file join $::tcltest::temporaryDirectory *]] {
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($testFileName) $newFiles
}
}
if {$calledFromAllFile || $::tcltest::testSingleFile} {
puts -nonewline $::tcltest::outputChannel "$testFileName:"
foreach index [list "Total" "Passed" "Skipped" "Failed"] {
puts -nonewline $::tcltest::outputChannel \
"\t$index\t$::tcltest::numTests($index)"
}
puts $::tcltest::outputChannel ""
if {$calledFromAllFile} {
puts $::tcltest::outputChannel \
"Sourced $::tcltest::numTestFiles Test Files."
set ::tcltest::numTestFiles 0
if {[llength $::tcltest::failFiles] > 0} {
puts $::tcltest::outputChannel \
"Files with failing tests: $::tcltest::failFiles"
set ::tcltest::failFiles {}
}
}
set constraintList [array names ::tcltest::skippedBecause]
if {[llength $constraintList] > 0} {
puts $::tcltest::outputChannel \
"Number of tests skipped for each constraint:"
foreach constraint [lsort $constraintList] {
puts $::tcltest::outputChannel \
"\t$::tcltest::skippedBecause($constraint)\t$constraint"
unset ::tcltest::skippedBecause($constraint)
}
}
set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]]
if {[llength $testFilesThatTurded] > 0} {
puts $::tcltest::outputChannel "Warning: files left behind:"
foreach testFile $testFilesThatTurded {
puts $::tcltest::outputChannel \
"\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] && ![info exists tcl_interactive]} {
exit
}
} else {
incr ::tcltest::numTestFiles
if {($::tcltest::currentFailure) && \
([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} {
lappend ::tcltest::failFiles $testFileName
}
set ::tcltest::currentFailure false
set newEnv {}
set changedEnv {}
set removedEnv {}
foreach index [array names ::env] {
if {![info exists ::tcltest::originalEnv($index)]} {
lappend newEnv $index
unset ::env($index)
} else {
if {$::env($index) != $::tcltest::originalEnv($index)} {
lappend changedEnv $index
set ::env($index) $::tcltest::originalEnv($index)
}
}
}
foreach index [array names ::tcltest::originalEnv] {
if {![info exists ::env($index)]} {
lappend removedEnv $index
set ::env($index) $::tcltest::originalEnv($index)
}
}
if {[llength $newEnv] > 0} {
puts $::tcltest::outputChannel \
"env array elements created:\t$newEnv"
}
if {[llength $changedEnv] > 0} {
puts $::tcltest::outputChannel \
"env array elements changed:\t$changedEnv"
}
if {[llength $removedEnv] > 0} {
puts $::tcltest::outputChannel \
"env array elements removed:\t$removedEnv"
}
set changedTclPlatform {}
foreach index [array names ::tcltest::originalTclPlatform] {
if {$::tcl_platform($index) != \
$::tcltest::originalTclPlatform($index)} {
lappend changedTclPlatform $index
set ::tcl_platform($index) \
$::tcltest::originalTclPlatform($index)
}
}
if {[llength $changedTclPlatform] > 0} {
puts $::tcltest::outputChannel \
"tcl_platform array elements changed:\t$changedTclPlatform"
}
if {[file exists [file join $::tcltest::workingDirectory core]]} {
if {$::tcltest::preserveCore > 1} {
puts $::tcltest::outputChannel "produced core file! \
Moving file to: \
[file join $::tcltest::temporaryDirectory core-$name]"
flush $::tcltest::outputChannel
catch {file rename -force \
[file join $::tcltest::workingDirectory core] \
[file join $::tcltest::temporaryDirectory \
core-$name]} msg
if {[string length $msg] > 0} {
::tcltest::PrintError "Problem renaming file: $msg"
}
} else {
if {[info exists ::tcltest::coreModificationTime]} {
if {$::tcltest::coreModificationTime != [file mtime \
[file join $::tcltest::workingDirectory core]]} {
puts $::tcltest::outputChannel "A core file was created!"
}
} else {
puts $::tcltest::outputChannel "A core file was created!"
}
}
}
}
}
if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} {
proc ::tcltest::cleanupTestsHook {} {}
}
proc ::tcltest::test {name description script expectedAnswer args} {
DebugPuts 3 "Running $name ($description)"
incr ::tcltest::numTests(Total)
foreach pattern $::tcltest::skip {
if {[string match $pattern $name]} {
incr ::tcltest::numTests(Skipped)
DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedSkip}
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)
DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedNonMatch}
return
}
}
set i [llength $args]
if {$i == 0} {
set constraints {}
if {$::tcltest::limitConstraints} {
::tcltest::AddToSkippedBecause userSpecifiedLimitConstraint
incr ::tcltest::numTests(Skipped)
return
}
} 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 {[.\w]+} $constraints \
{$::tcltest::testConstraints(&)} c
catch {set doTest [eval expr $c]}
} else {
set doTest 1
foreach constraint $constraints {
if {(![info exists ::tcltest::testConstraints($constraint)]) \
|| (!$::tcltest::testConstraints($constraint))} {
set doTest 0
set constraints $constraint
break
}
}
}
if {$doTest == 0} {
if {[string first s $::tcltest::verbose] != -1} {
puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints"
}
incr ::tcltest::numTests(Skipped)
::tcltest::AddToSkippedBecause $constraints
return
}
} else {
error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
}
if {$::tcltest::preserveCore} {
set currentTclPlatform [array get tcl_platform]
array set tcl_platform $::tcltest::originalTclPlatform
if {[file exists [file join $::tcltest::workingDirectory core]]} {
set coreModTime [file mtime [file join \
$::tcltest::workingDirectory core]]
}
array set tcl_platform $currentTclPlatform
}
if {[info commands memory] != {}} {
memory tag $name
}
set code [catch {uplevel $script} actualAnswer]
if {([string equal $actualAnswer $expectedAnswer]) && ($code == 0)} {
incr ::tcltest::numTests(Passed)
if {[string first p $::tcltest::verbose] != -1} {
puts $::tcltest::outputChannel "++++ $name PASSED"
}
} else {
incr ::tcltest::numTests(Failed)
set ::tcltest::currentFailure true
if {[string first b $::tcltest::verbose] == -1} {
set script ""
}
puts $::tcltest::outputChannel "\n==== $name $description FAILED"
if {$script != ""} {
puts $::tcltest::outputChannel "==== Contents of test case:"
puts $::tcltest::outputChannel $script
}
if {$code != 0} {
if {$code == 1} {
puts $::tcltest::outputChannel "==== Test generated error:"
puts $::tcltest::outputChannel $actualAnswer
} elseif {$code == 2} {
puts $::tcltest::outputChannel "==== Test generated return exception; result was:"
puts $::tcltest::outputChannel $actualAnswer
} elseif {$code == 3} {
puts $::tcltest::outputChannel "==== Test generated break exception"
} elseif {$code == 4} {
puts $::tcltest::outputChannel "==== Test generated continue exception"
} else {
puts $::tcltest::outputChannel "==== Test generated exception $code; message was:"
puts $::tcltest::outputChannel $actualAnswer
}
} else {
puts $::tcltest::outputChannel "---- Result was:\n$actualAnswer"
}
puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer"
puts $::tcltest::outputChannel "==== $name FAILED\n"
}
if {$::tcltest::preserveCore} {
set currentTclPlatform [array get tcl_platform]
if {[file exists [file join $::tcltest::workingDirectory core]]} {
if {$::tcltest::preserveCore > 1} {
puts $::tcltest::outputChannel "==== $name produced core file! \
Moving file to: \
[file join $::tcltest::temporaryDirectory core-$name]"
catch {file rename -force \
[file join $::tcltest::workingDirectory core] \
[file join $::tcltest::temporaryDirectory \
core-$name]} msg
if {[string length $msg] > 0} {
::tcltest::PrintError "Problem renaming file: $msg"
}
} else {
if {[info exists coreModTime]} {
if {$coreModTime != [file mtime \
[file join $::tcltest::workingDirectory core]]} {
puts $::tcltest::outputChannel "==== $name produced core file!"
}
} else {
puts $::tcltest::outputChannel "==== $name produced core file!"
}
}
}
array set tcl_platform $currentTclPlatform
}
}
proc ::tcltest::getMatchingFiles {args} {
set matchingFiles {}
if {[llength $args]} {
set searchDirectory $args
} else {
set searchDirectory [list $::tcltest::testsDirectory]
}
foreach directory $searchDirectory {
set matchFileList {}
foreach match $::tcltest::matchFiles {
set matchFileList [concat $matchFileList \
[glob -nocomplain [file join $directory $match]]]
}
if {[string compare {} $::tcltest::skipFiles]} {
set skipFileList {}
foreach skip $::tcltest::skipFiles {
set skipFileList [concat $skipFileList \
[glob -nocomplain [file join $directory $skip]]]
}
foreach file $matchFileList {
if {([lsearch -exact $skipFileList $file] == -1) && \
(![string match l.*.test [file tail $file]])} {
lappend matchingFiles $file
}
}
} else {
set matchingFiles [concat $matchingFiles $matchFileList]
}
}
if {[string equal $matchingFiles {}]} {
::tcltest::PrintError "No test files remain after applying \
your match and skip patterns!"
}
return $matchingFiles
}
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
}
proc ::tcltest::saveState {} {
uplevel DebugPuts 2 "::tcltest::saveState: $::tcltest::saveState"
}
proc ::tcltest::restoreState {} {
foreach p [info procs] {
if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \
(![string equal ::tcltest::$p [namespace origin $p]])} {
DebugPuts 3 "::tcltest::restoreState: Removing proc $p"
rename $p {}
}
}
foreach p [uplevel if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
DebugPuts 3 "::tcltest::restoreState: Removing variable $p"
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} {
global tcl_platform
DebugPuts 3 "::tcltest::makeFile: putting $contents into $name"
set fullName [file join $::tcltest::temporaryDirectory $name]
set fd [open $fullName w]
fconfigure $fd -translation lf
if {[string equal [string index $contents end] "\n"]} {
puts -nonewline $fd $contents
} else {
puts $fd $contents
}
close $fd
if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
lappend ::tcltest::filesMade $fullName
}
return $fullName
}
proc ::tcltest::removeFile {name} {
DebugPuts 3 "::tcltest::removeFile: removing $name"
file delete [file join $::tcltest::temporaryDirectory $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 {([string equal $tcl_platform(platform) "macintosh"]) || \
($::tcltest::testConstraints(unixExecs) == 0)} {
set f [open [file join $::tcltest::temporaryDirectory $name]]
set data [read -nonewline $f]
close $f
return $data
} else {
exec cat [file join $::tcltest::temporaryDirectory $name]
}
}
proc ::tcltest::grep { expression searchList } {
foreach element $searchList {
if {[regsub -all CURRENT_ELEMENT $expression $element \
newExpression] == 0} {
set newExpression "$expression {$element}"
}
if {[eval $newExpression] == 1} {
lappend returnList $element
}
}
if {[info exists returnList]} {
return $returnList
}
return
}
proc ::tcltest::bytestring {string} {
encoding convertfrom identity $string
}
proc ::tcltest::set_iso8859_1_locale {} {
if {[info commands testlocale] != ""} {
set ::tcltest::previousLocale [testlocale ctype]
testlocale ctype $::tcltest::isoLocale
}
return
}
proc ::tcltest::restore_locale {} {
if {[info commands testlocale] != ""} {
testlocale ctype $::tcltest::previousLocale
}
return
}
proc ::tcltest::threadReap {} {
if {[info commands testthread] != {}} {
testthread errorproc ThreadNullError
while {[llength [testthread names]] > 1} {
foreach tid [testthread names] {
if {$tid != $::tcltest::mainThread} {
catch {testthread send -async $tid {testthread exit}}
}
}
after 1
}
testthread errorproc ThreadError
return [llength [testthread names]]
} elseif {[info commands thread::id] != {}} {
thread::errorproc ThreadNullError
while {[llength [thread::names]] > 1} {
foreach tid [thread::names] {
if {$tid != $::tcltest::mainThread} {
catch {thread::send -async $tid {thread::exit}}
}
}
after 1
}
thread::errorproc ThreadError
return [llength [thread::names]]
} else {
return 1
}
}
namespace eval tcltest {
set ::auto_path [list [info library]]
::tcltest::initConstraints
if {[namespace children ::tcltest] == {}} {
::tcltest::processCmdLineArgs
}
}