package require Tcl 8.3 ;namespace eval tcltest {
variable Version 2.2.1
variable version [package provide Tcl]
variable patchLevel [info patchlevel]
namespace export cleanupTests loadTestedCommands makeDirectory \
makeFile removeDirectory removeFile runAllTests test
namespace export configure customMatch errorChannel interpreter \
outputChannel testConstraint
namespace export bytestring ; namespace export debug ; namespace export errorFile ; namespace export limitConstraints ; namespace export loadFile ; namespace export loadScript ; namespace export match ; namespace export matchFiles ; namespace export matchDirectories ; namespace export normalizeMsg ; namespace export normalizePath ; namespace export outputFile ; namespace export preserveCore ; namespace export singleProcess ; namespace export skip ; namespace export skipFiles ; namespace export skipDirectories ; namespace export temporaryDirectory ; namespace export testsDirectory ; namespace export verbose ; namespace export viewFile ; namespace export workingDirectory ;
namespace export getMatchingFiles mainThread restoreState saveState \
threadReap
proc normalizePath {pathVar} {
upvar $pathVar path
set oldpwd [pwd]
catch {cd $path}
set path [pwd]
cd $oldpwd
return $path
}
proc AcceptAll {value} {
return $value
}
proc AcceptList { list } {
return [lrange $list 0 end]
}
proc AcceptPattern { pattern } {
return [AcceptAll $pattern]
}
proc AcceptInteger { level } {
return [incr level 0]
}
proc AcceptBoolean { boolean } {
return [expr {$boolean && $boolean}]
}
proc AcceptScript { script } {
if {![info complete $script]} {
return -code error "invalid Tcl script: $script"
}
return $script
}
proc AcceptAbsolutePath { path } {
return [file join [pwd] $path]
}
proc AcceptReadable { path } {
if {![file readable $path]} {
return -code error "\"$path\" is not readable"
}
return $path
}
proc AcceptDirectory { directory } {
set directory [AcceptAbsolutePath $directory]
if {![file exists $directory]} {
return -code error "\"$directory\" does not exist"
}
if {![file isdir $directory]} {
return -code error "\"$directory\" is not a directory"
}
return [AcceptReadable $directory]
}
proc ArrayDefault {varName value} {
variable $varName
if {[array exists $varName]} {
return
}
if {[info exists $varName]} {
unset $varName
}
array set $varName $value
}
ArrayDefault originalEnv [array get ::env]
ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
ArrayDefault createdNewFiles {}
ArrayDefault skippedBecause {}
ArrayDefault testConstraints {}
proc Default {varName value {verify AcceptAll}} {
variable $varName
if {![info exists $varName]} {
variable $varName [$verify $value]
} else {
variable $varName [$verify [set $varName]]
}
}
Default parameters {}
Default numTestFiles 0 AcceptInteger
Default testSingleFile true AcceptBoolean
Default currentFailure false AcceptBoolean
Default failFiles {} AcceptList
Default filesMade {} AcceptList
Default filesExisted {} AcceptList
variable FilesExistedFilled 0
proc FillFilesExisted {} {
variable FilesExistedFilled
if {$FilesExistedFilled} {return}
variable filesExisted
foreach file [glob -nocomplain -directory [temporaryDirectory] *] {
lappend filesExisted [file tail $file]
}
set FilesExistedFilled 1
}
Default constraintsSpecified {} AcceptList
trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \
[array names ::tcltest::testConstraints] ;
Default mainThread 1
variable mainThread
if {[info commands thread::id] != {}} {
set mainThread [thread::id]
} elseif {[info commands testthread] != {}} {
set mainThread [testthread id]
}
variable workingDirectory
trace variable workingDirectory w \
[namespace code {cd $workingDirectory ;
Default workingDirectory [pwd] AcceptAbsolutePath
proc workingDirectory { {dir ""} } {
variable workingDirectory
if {[llength [info level 0]] == 1} {
return $workingDirectory
}
set workingDirectory [AcceptAbsolutePath $dir]
}
Default tcltest [info nameofexecutable]
trace variable tcltest w [namespace code {testConstraint stdio \
[eval [ConstraintInitializer stdio]] ;
Default originalTclPlatform [array get ::tcl_platform]
if {[file exists [file join [workingDirectory] core]]} {
Default coreModTime \
[file mtime [file join [workingDirectory] core]]
}
Default outData {}
Default errData {}
variable testLevel 0
Default saveState {}
if {![info exists [namespace current]::isoLocale]} {
variable isoLocale fr
switch -- $::tcl_platform(platform) {
"unix" {
switch -exact -- $::tcl_platform(os) {
"FreeBSD" {
set isoLocale fr_FR.ISO_8859-1
}
HP-UX {
set isoLocale fr_FR.iso88591
}
Linux -
IRIX {
set isoLocale fr
}
default {
set isoLocale iso_8859_1
}
}
}
"windows" {
set isoLocale French
}
}
}
Default outputChannel stdout
proc outputChannel { {filename ""} } {
variable outputChannel
set dummy [debug]
if {[llength [info level 0]] == 1} {
return $outputChannel
}
switch -exact -- $filename {
stderr -
stdout {
set outputChannel $filename
}
default {
set outputChannel [open $filename a]
}
}
return $outputChannel
}
Default errorChannel stderr
proc errorChannel { {filename ""} } {
variable errorChannel
set dummy [debug]
if {[llength [info level 0]] == 1} {
return $errorChannel
}
switch -exact -- $filename {
stderr -
stdout {
set errorChannel $filename
}
default {
set errorChannel [open $filename a]
}
}
return $errorChannel
}
variable Option; array set Option {}
variable Usage; array set Usage {}
variable Verify; array set Verify {}
proc Option {option value usage {verify AcceptAll} {varName {}}} {
variable Option
variable Verify
variable Usage
variable OptionControlledVariables
set Usage($option) $usage
set Verify($option) $verify
if {[catch {$verify $value} msg]} {
return -code error $msg
} else {
set Option($option) $msg
}
if {[string length $varName]} {
variable $varName
if {[info exists $varName]} {
if {[catch {$verify [set $varName]} msg]} {
return -code error $msg
} else {
set Option($option) $msg
}
unset $varName
}
namespace eval [namespace current] \
[list upvar 0 Option($option) $varName]
lappend OptionControlledVariables $varName
proc $varName {{value {}}} [subst -nocommands {
if {[llength [info level 0]] == 2} {
Configure $option [set value]
}
return [Configure $option]
}]
}
}
proc MatchingOption {option} {
variable Option
set match [array names Option $option*]
switch -- [llength $match] {
0 {
set sorted [lsort [array names Option]]
set values [join [lrange $sorted 0 end-1] ", "]
append values ", or [lindex $sorted end]"
return -code error "unknown option $option: should be\
one of $values"
}
1 {
return [lindex $match 0]
}
default {
if {[lsearch -exact $match $option] >= 0} {
return $option
}
set values [join [lrange $match 0 end-1] ", "]
append values ", or [lindex $match end]"
return -code error "ambiguous option $option:\
could match $values"
}
}
}
proc EstablishAutoConfigureTraces {} {
variable OptionControlledVariables
foreach varName [concat $OptionControlledVariables Option] {
variable $varName
trace variable $varName r [namespace code {ProcessCmdLineArgs ; }
}
proc RemoveAutoConfigureTraces {} {
variable OptionControlledVariables
foreach varName [concat $OptionControlledVariables Option] {
variable $varName
foreach pair [trace vinfo $varName] {
foreach {op cmd} $pair break
if {[string equal r $op]
&& [string match *ProcessCmdLineArgs* $cmd]} {
trace vdelete $varName $op $cmd
}
}
}
proc RemoveAutoConfigureTraces {} {}
}
proc Configure args {
variable Option
variable Verify
set n [llength $args]
if {$n == 0} {
return [lsort [array names Option]]
}
if {$n == 1} {
if {[catch {MatchingOption [lindex $args 0]} option]} {
return -code error $option
}
return $Option($option)
}
while {[llength $args] > 1} {
if {[catch {MatchingOption [lindex $args 0]} option]} {
return -code error $option
}
if {[catch {$Verify($option) [lindex $args 1]} value]} {
return -code error "invalid $option\
value \"[lindex $args 1]\": $value"
}
set Option($option) $value
set args [lrange $args 2 end]
}
if {[llength $args]} {
if {[catch {MatchingOption [lindex $args 0]} option]} {
return -code error $option
}
return -code error "missing value for option $option"
}
}
proc configure args {
RemoveAutoConfigureTraces
set code [catch {eval Configure $args} msg]
return -code $code $msg
}
proc AcceptVerbose { level } {
set level [AcceptList $level]
if {[llength $level] == 1} {
if {![regexp {^(pass|body|skip|start|error)$} $level]} {
set level [string map {p pass b body s skip t start e error} \
[split $level {}]]
}
}
set valid [list]
foreach v $level {
if {[regexp {^(pass|body|skip|start|error)$} $v]} {
lappend valid $v
}
}
return $valid
}
proc IsVerbose {level} {
variable Option
return [expr {[lsearch -exact $Option(-verbose) $level] != -1}]
}
Option -verbose body {
Takes any combination of the values 'p', 's', 'b', 't' and 'e'.
Test suite will display all passed tests if 'p' is specified, all
skipped tests if 's' is specified, the bodies of failed tests if
'b' is specified, and when tests start if 't' is specified.
ErrorInfo is displayed if 'e' is specified.
} AcceptVerbose verbose
Option -match * {
Run all tests within the specified files that match one of the
list of glob patterns given.
} AcceptList match
Option -skip {} {
Skip all tests within the specified tests (via -match) and files
that match one of the list of glob patterns given.
} AcceptList skip
Option -file *.test {
Run tests in all test files that match the glob pattern given.
} AcceptPattern matchFiles
Option -notfile l.*.test {
Skip all test files that match the glob pattern given.
} AcceptPattern skipFiles
Option -relateddir * {
Run tests in directories that match the glob pattern given.
} AcceptPattern matchDirectories
Option -asidefromdir {} {
Skip tests in directories that match the glob pattern given.
} AcceptPattern skipDirectories
Option -preservecore 0 {
If 2, save any core files produced during testing in the directory
specified by -tmpdir. If 1, notify the user if core files are
created.
} AcceptInteger preserveCore
Option -debug 0 {
Internal debug level
} AcceptInteger debug
proc SetSelectedConstraints args {
variable Option
foreach c $Option(-constraints) {
testConstraint $c 1
}
}
Option -constraints {} {
Do not skip the listed constraints listed in -constraints.
} AcceptList
trace variable Option(-constraints) w \
[namespace code {SetSelectedConstraints ;
proc ClearUnselectedConstraints args {
variable Option
variable testConstraints
if {!$Option(-limitconstraints)} {return}
foreach c [array names testConstraints] {
if {[lsearch -exact $Option(-constraints) $c] == -1} {
testConstraint $c 0
}
}
}
Option -limitconstraints false {
whether to run only tests with the constraints
} AcceptBoolean limitConstraints
trace variable Option(-limitconstraints) w \
[namespace code {ClearUnselectedConstraints ;
Option -load {} {
Specifies the script to load the tested commands.
} AcceptScript loadScript
Option -singleproc 0 {
whether to run all tests in one process
} AcceptBoolean singleProcess
proc AcceptTemporaryDirectory { directory } {
set directory [AcceptAbsolutePath $directory]
if {![file exists $directory]} {
file mkdir $directory
}
set directory [AcceptDirectory $directory]
if {![file writable $directory]} {
if {[string equal [workingDirectory] $directory]} {
return $directory
}
return -code error "\"$directory\" is not writeable"
}
return $directory
}
Option -tmpdir [workingDirectory] {
Save temporary files in the specified directory.
} AcceptTemporaryDirectory temporaryDirectory
trace variable Option(-tmpdir) w \
[namespace code {normalizePath Option(-tmpdir) ;
Option -testdir [workingDirectory] {
Search tests in the specified directory.
} AcceptDirectory testsDirectory
trace variable Option(-testdir) w \
[namespace code {normalizePath Option(-testdir) ;
proc AcceptLoadFile { file } {
if {[string equal "" $file]} {return $file}
set file [file join [temporaryDirectory] $file]
return [AcceptReadable $file]
}
proc ReadLoadScript {args} {
variable Option
if {[string equal "" $Option(-loadfile)]} {return}
set tmp [open $Option(-loadfile) r]
loadScript [read $tmp]
close $tmp
}
Option -loadfile {} {
Read the script to load the tested commands from the specified file.
} AcceptLoadFile loadFile
trace variable Option(-loadfile) w [namespace code ReadLoadScript]
proc AcceptOutFile { file } {
if {[string equal stderr $file]} {return $file}
if {[string equal stdout $file]} {return $file}
return [file join [temporaryDirectory] $file]
}
Option -outfile stdout {
Send output from test runs to the specified file.
} AcceptOutFile outputFile
trace variable Option(-outfile) w \
[namespace code {outputChannel $Option(-outfile) ;
Option -errfile stderr {
Send errors from test runs to the specified file.
} AcceptOutFile errorFile
trace variable Option(-errfile) w \
[namespace code {errorChannel $Option(-errfile) ;
}
proc tcltest::DebugPuts {level string} {
variable debug
if {$debug >= $level} {
puts $string
}
return
}
proc tcltest::DebugPArray {level arrayvar} {
variable debug
if {$debug >= $level} {
catch {upvar $arrayvar $arrayvar}
parray $arrayvar
}
return
}
auto_load ::parray
proc tcltest::parray {a {pattern *}} [info body ::parray]
proc tcltest::DebugDo {level script} {
variable debug
if {$debug >= $level} {
uplevel 1 $script
}
return
}
proc tcltest::Warn {msg} {
puts [outputChannel] "WARNING: $msg"
}
proc tcltest::mainThread { {new ""} } {
variable mainThread
if {[llength [info level 0]] == 1} {
return $mainThread
}
set mainThread $new
}
proc tcltest::testConstraint {constraint {value ""}} {
variable testConstraints
variable Option
DebugPuts 3 "entering testConstraint $constraint $value"
if {[llength [info level 0]] == 2} {
return $testConstraints($constraint)
}
if {[catch {expr {$value && $value}} msg]} {
return -code error $msg
}
if {[limitConstraints]
&& [lsearch -exact $Option(-constraints) $constraint] == -1} {
set value 0
}
set testConstraints($constraint) $value
}
proc tcltest::interpreter { {interp ""} } {
variable tcltest
if {[llength [info level 0]] == 1} {
return $tcltest
}
if {[string equal {} $interp]} {
set tcltest {}
} else {
set tcltest $interp
}
}
proc tcltest::AddToSkippedBecause { constraint {value 1}} {
variable skippedBecause
if {[info exists skippedBecause($constraint)]} {
incr skippedBecause($constraint) $value
} else {
set skippedBecause($constraint) $value
}
return
}
proc tcltest::PrintError {errorMsg} {
set InitialMessage "Error: "
set InitialMsgLen [string length $InitialMessage]
puts -nonewline [errorChannel] $InitialMessage
set endingIndex [string length $errorMsg]
if {$endingIndex < (80 - $InitialMsgLen)} {
puts [errorChannel] $errorMsg
} else {
set beginningIndex [string last " " [string range $errorMsg 0 \
[expr {80 - $InitialMsgLen}]]]
puts [errorChannel] [string range $errorMsg 0 $beginningIndex]
while {![string equal end $beginningIndex]} {
puts -nonewline [errorChannel] \
[string repeat " " $InitialMsgLen]
if {($endingIndex - $beginningIndex)
< (80 - $InitialMsgLen)} {
puts [errorChannel] [string trim \
[string range $errorMsg $beginningIndex end]]
break
} else {
set newEndingIndex [expr {[string last " " \
[string range $errorMsg $beginningIndex \
[expr {$beginningIndex
+ (80 - $InitialMsgLen)}]
]] + $beginningIndex}]
if {($newEndingIndex <= 0)
|| ($newEndingIndex <= $beginningIndex)} {
set newEndingIndex end
}
puts [errorChannel] [string trim \
[string range $errorMsg \
$beginningIndex $newEndingIndex]]
set beginningIndex $newEndingIndex
}
}
}
flush [errorChannel]
return
}
proc tcltest::SafeFetch {n1 n2 op} {
variable testConstraints
DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
if {[string equal {} $n2]} {return}
if {![info exists testConstraints($n2)]} {
if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
testConstraint $n2 0
}
}
}
proc tcltest::ConstraintInitializer {constraint {script ""}} {
variable ConstraintInitializer
DebugPuts 3 "entering ConstraintInitializer $constraint $script"
if {[llength [info level 0]] == 2} {
return $ConstraintInitializer($constraint)
}
if {![info complete $script]} {
return -code error "ConstraintInitializer must be complete script"
}
set ConstraintInitializer($constraint) $script
}
proc tcltest::InitConstraints {} {
variable ConstraintInitializer
initConstraintsHook
foreach constraint [array names ConstraintInitializer] {
testConstraint $constraint
}
}
proc tcltest::DefineConstraintInitializers {} {
ConstraintInitializer singleTestInterp {singleProcess}
ConstraintInitializer unixOnly \
{string equal $::tcl_platform(platform) unix}
ConstraintInitializer macOnly \
{string equal $::tcl_platform(platform) macintosh}
ConstraintInitializer pcOnly \
{string equal $::tcl_platform(platform) windows}
ConstraintInitializer winOnly \
{string equal $::tcl_platform(platform) windows}
ConstraintInitializer unix {testConstraint unixOnly}
ConstraintInitializer mac {testConstraint macOnly}
ConstraintInitializer pc {testConstraint pcOnly}
ConstraintInitializer win {testConstraint winOnly}
ConstraintInitializer unixOrPc \
{expr {[testConstraint unix] || [testConstraint pc]}}
ConstraintInitializer macOrPc \
{expr {[testConstraint mac] || [testConstraint pc]}}
ConstraintInitializer unixOrWin \
{expr {[testConstraint unix] || [testConstraint win]}}
ConstraintInitializer macOrWin \
{expr {[testConstraint mac] || [testConstraint win]}}
ConstraintInitializer macOrUnix \
{expr {[testConstraint mac] || [testConstraint unix]}}
ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"}
ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"}
ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"}
ConstraintInitializer tempNotPc {expr {![testConstraint pc]}}
ConstraintInitializer tempNotWin {expr {![testConstraint win]}}
ConstraintInitializer tempNotMac {expr {![testConstraint mac]}}
ConstraintInitializer tempNotUnix {expr {![testConstraint unix]}}
ConstraintInitializer pcCrash {expr {![testConstraint pc]}}
ConstraintInitializer winCrash {expr {![testConstraint win]}}
ConstraintInitializer macCrash {expr {![testConstraint mac]}}
ConstraintInitializer unixCrash {expr {![testConstraint unix]}}
ConstraintInitializer emptyTest {format 0}
ConstraintInitializer knownBug {format 0}
ConstraintInitializer nonPortable {format 0}
ConstraintInitializer userInteraction {format 0}
ConstraintInitializer interactive \
{expr {[info exists ::tcl_interactive] && $::tcl_interactive}}
ConstraintInitializer root {expr \
{[string equal unix $::tcl_platform(platform)]
&& ([string equal root $::tcl_platform(user)]
|| [string equal "" $::tcl_platform(user)])}}
ConstraintInitializer notRoot {expr {![testConstraint root]}}
ConstraintInitializer nonBlockFiles {
set code [expr {[catch {set f [open defs r]}]
|| [catch {fconfigure $f -blocking off}]}]
catch {close $f}
set code
}
ConstraintInitializer asyncPipeClose {expr {
!([string equal unix $::tcl_platform(platform)]
&& ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}}
ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}
ConstraintInitializer unixExecs {
set code 1
if {[string equal macintosh $::tcl_platform(platform)]} {
set code 0
}
if {[string equal windows $::tcl_platform(platform)]} {
if {[catch {
set file _tcl_test_remove_me.txt
makeFile {hello} $file
}]} {
set code 0
} elseif {
[catch {exec cat $file}] ||
[catch {exec echo hello}] ||
[catch {exec sh -c echo hello}] ||
[catch {exec wc $file}] ||
[catch {exec sleep 1}] ||
[catch {exec echo abc > $file}] ||
[catch {exec chmod 644 $file}] ||
[catch {exec rm $file}] ||
[llength [auto_execok mkdir]] == 0 ||
[llength [auto_execok fgrep]] == 0 ||
[llength [auto_execok grep]] == 0 ||
[llength [auto_execok ps]] == 0
} {
set code 0
}
removeFile $file
}
set code
}
ConstraintInitializer stdio {
set code 0
if {![catch {set f [open "|[list [interpreter]]" w]}]} {
if {![catch {puts $f exit}]} {
if {![catch {close $f}]} {
set code 1
}
}
}
set code
}
ConstraintInitializer socket {
catch {socket} msg
string compare $msg "sockets are not available on this system"
}
ConstraintInitializer hasIsoLocale {
if {[llength [info commands testlocale]] == 0} {
set code 0
} else {
set code [string length [SetIso8859_1_Locale]]
RestoreLocale
}
set code
}
}
proc tcltest::PrintUsageInfo {} {
puts [Usage]
PrintUsageInfoHook
}
proc tcltest::Usage { {option ""} } {
variable Usage
variable Verify
if {[llength [info level 0]] == 1} {
set msg "Usage: [file tail [info nameofexecutable]] script "
append msg "?-help? ?flag value? ... \n"
append msg "Available flags (and valid input values) are:"
set max 0
set allOpts [concat -help [Configure]]
foreach opt $allOpts {
set foo [Usage $opt]
foreach [list x type($opt) usage($opt)] $foo break
set line($opt) " $opt $type($opt) "
set length($opt) [string length $line($opt)]
if {$length($opt) > $max} {set max $length($opt)}
}
set rest [expr {72 - $max}]
foreach opt $allOpts {
append msg \n$line($opt)
append msg [string repeat " " [expr {$max - $length($opt)}]]
set u [string trim $usage($opt)]
catch {append u " (default: \[[Configure $opt]])"}
regsub -all {\s*\n\s*} $u " " u
while {[string length $u] > $rest} {
set break [string wordstart $u $rest]
if {$break == 0} {
set break [string wordend $u 0]
}
append msg [string range $u 0 [expr {$break - 1}]]
set u [string trim [string range $u $break end]]
append msg \n[string repeat " " $max]
}
append msg $u
}
return $msg\n
} elseif {[string equal -help $option]} {
return [list -help "" "Display this usage information."]
} else {
set type [lindex [info args $Verify($option)] 0]
return [list $option $type $Usage($option)]
}
}
proc tcltest::ProcessFlags {flagArray} {
if {[lsearch -exact $flagArray {-help}] != -1} {
PrintUsageInfo
exit 1
}
if {[llength $flagArray] == 0} {
RemoveAutoConfigureTraces
} else {
set args $flagArray
while {[llength $args] && [catch {eval configure $args} msg]} {
if {[regexp {^unknown option (\S+):} $msg -> option]} {
set moreOptions [processCmdLineArgsAddFlagsHook]
if {[lsearch -exact $moreOptions $option] == -1} {
if {[llength $moreOptions]} {
append msg ", "
append msg [join [lrange $moreOptions 0 end -1] ", "]
append msg "or [lindex $moreOptions end]"
}
Warn $msg
}
} else {
puts [errorChannel] $msg
exit 1
}
while {![string equal [lindex $args 0] $option]} {
set args [lrange $args 2 end]
}
set args [lrange $args 2 end]
}
}
array set flag $flagArray
processCmdLineArgsHook [array get flag]
return
}
proc tcltest::ProcessCmdLineArgs {} {
variable originalEnv
variable testConstraints
if {![info exists ::argv]} {
ProcessFlags {}
} else {
ProcessFlags $::argv
}
DebugPuts 2 "Flags passed into tcltest:"
if {[info exists ::env(TCLTEST_OPTIONS)]} {
DebugPuts 2 \
" ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
}
if {[info exists argv]} {
DebugPuts 2 " argv: $argv"
}
DebugPuts 2 "tcltest::debug = [debug]"
DebugPuts 2 "tcltest::testsDirectory = [testsDirectory]"
DebugPuts 2 "tcltest::workingDirectory = [workingDirectory]"
DebugPuts 2 "tcltest::temporaryDirectory = [temporaryDirectory]"
DebugPuts 2 "tcltest::outputChannel = [outputChannel]"
DebugPuts 2 "tcltest::errorChannel = [errorChannel]"
DebugPuts 2 "Original environment (tcltest::originalEnv):"
DebugPArray 2 originalEnv
DebugPuts 2 "Constraints:"
DebugPArray 2 testConstraints
}
namespace eval tcltest::Replace {
namespace export puts
}
proc tcltest::Replace::puts {args} {
variable [namespace parent]::outData
variable [namespace parent]::errData
switch [llength $args] {
1 {
append outData [lindex $args 0]\n
return
}
2 {
if {[string equal -nonewline [lindex $args 0]]} {
append outData [lindex $args end]
return
} else {
set channel [lindex $args 0]
set newline \n
}
}
3 {
if {[string equal -nonewline [lindex $args 0]]} {
set channel [lindex $args 1]
set newline ""
}
}
}
if {[info exists channel]} {
if {[string equal $channel [[namespace parent]::outputChannel]]
|| [string equal $channel stdout]} {
append outData [lindex $args end]$newline
return
} elseif {[string equal $channel [[namespace parent]::errorChannel]]
|| [string equal $channel stderr]} {
append errData [lindex $args end]$newline
return
}
}
return [eval Puts $args]
}
proc tcltest::Eval {script {ignoreOutput 1}} {
variable outData
variable errData
DebugPuts 3 "[lindex [info level 0] 0] called"
if {!$ignoreOutput} {
set outData {}
set errData {}
set callerHasPuts [llength [uplevel 1 {
::info commands [::namespace current]::puts
}]]
if {$callerHasPuts} {
uplevel 1 [list ::rename puts [namespace current]::Replace::Puts]
} else {
interp alias {} [namespace current]::Replace::Puts {} ::puts
}
uplevel 1 [list ::namespace import [namespace origin Replace::puts]]
namespace import Replace::puts
}
set result [uplevel 1 $script]
if {!$ignoreOutput} {
namespace forget puts
uplevel 1 ::namespace forget puts
if {$callerHasPuts} {
uplevel 1 [list ::rename [namespace current]::Replace::Puts puts]
} else {
interp alias {} [namespace current]::Replace::Puts {}
}
}
return $result
}
proc tcltest::CompareStrings {actual expected mode} {
variable CustomMatch
if {![info exists CustomMatch($mode)]} {
return -code error "No matching command registered for `-match $mode'"
}
set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]]
if {[catch {expr {$match && $match}} result]} {
return -code error "Invalid result from `-match $mode' command: $result"
}
return $match
}
proc tcltest::customMatch {mode script} {
variable CustomMatch
if {![info complete $script]} {
return -code error \
"invalid customMatch script; can't evaluate after completion"
}
set CustomMatch($mode) $script
}
proc tcltest::SubstArguments {argList} {
set result {}
set token ""
while {[string length $argList]} {
if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
$argList all]} {
# Get the text leading up to this word, but not including
# this word, from the argList.
set text [string range $argList 0 \
[expr {[lindex $all 0] - 1}]]
# Get the word with the quote
set word [string range $argList \
[lindex $all 0] [lindex $all 1]]
# Remove all text up to and including the word from the
# argList.
set argList [string range $argList \
[expr {[lindex $all 1] + 1}] end]
} else {
# Take everything up to the end of the argList.
set text $argList
set word {}
set argList {}
}
if {$token != {}} {
# If we saw a word with quote before, then there is a
# multi-word token starting with that word. In this case,
# add the text and the current word to this token.
append token $text $word
} else {
# Add the text to the result. There is no need to parse
# the text because it couldn't be a part of any multi-word
# token. Then start a new multi-word token with the word
# because we need to pass this token to the Tcl parser to
# check for balancing quotes
append result $text
set token $word
}
if { [catch {llength $token} length] == 0 && $length == 1} {
# The token is a valid list so add it to the result.
# lappend result [string trim $token]
append result \{$token\}
set token {}
}
}
# If the last token has not been added to the list then there
# is a problem.
if { [string length $token] } {
error "incomplete token \"$token\""
}
return $result
}
proc tcltest::test {name description args} {
global tcl_platform
variable testLevel
variable coreModTime
DebugPuts 3 "test $name $args"
FillFilesExisted
incr testLevel
foreach item {constraints setup cleanup body result returnCodes
match} {
set $item {}
}
set match exact
set returnCodes [list 0 2]
if {[string match -* [lindex $args 0]]
|| ([llength $args] <= 1)} {
if {[llength $args] == 1} {
set list [SubstArguments [lindex $args 0]]
foreach {element value} $list {
set testAttributes($element) $value
}
foreach item {constraints match setup body cleanup \
result returnCodes output errorOutput} {
if {[info exists testAttributes(-$item)]} {
set testAttributes(-$item) [uplevel 1 \
::concat $testAttributes(-$item)]
}
}
} else {
array set testAttributes $args
}
set validFlags {-setup -cleanup -body -result -returnCodes \
-match -output -errorOutput -constraints}
foreach flag [array names testAttributes] {
if {[lsearch -exact $validFlags $flag] == -1} {
incr testLevel -1
set sorted [lsort $validFlags]
set options [join [lrange $sorted 0 end-1] ", "]
append options ", or [lindex $sorted end]"
return -code error "bad option \"$flag\": must be $options"
}
}
foreach item [array names testAttributes] {
set [string trimleft $item "-"] $testAttributes($item)
}
variable CustomMatch
if {[lsearch [array names CustomMatch] $match] == -1} {
incr testLevel -1
set sorted [lsort [array names CustomMatch]]
set values [join [lrange $sorted 0 end-1] ", "]
append values ", or [lindex $sorted end]"
return -code error "bad -match value \"$match\":\
must be $values"
}
regsub -nocase normal $returnCodes 0 returnCodes
regsub -nocase error $returnCodes 1 returnCodes
regsub -nocase return $returnCodes 2 returnCodes
regsub -nocase break $returnCodes 3 returnCodes
regsub -nocase continue $returnCodes 4 returnCodes
} else {
set result [lindex $args end]
if {[llength $args] == 2} {
set body [lindex $args 0]
} elseif {[llength $args] == 3} {
set constraints [lindex $args 0]
set body [lindex $args 1]
} else {
incr testLevel -1
return -code error "wrong # args:\
should be \"test name desc ?options?\""
}
}
if {[Skipped $name $constraints]} {
incr testLevel -1
return
}
if {[preserveCore]} {
if {[file exists [file join [workingDirectory] core]]} {
set coreModTime [file mtime [file join [workingDirectory] core]]
}
}
set code [catch {uplevel 1 $setup} setupMsg]
set setupFailure [expr {$code != 0}]
if {!$setupFailure} {
if {[IsVerbose start]} {
puts [outputChannel] "---- $name start"
flush [outputChannel]
}
set command [list [namespace origin RunTest] $name $body]
if {[info exists output] || [info exists errorOutput]} {
set testResult [uplevel 1 [list [namespace origin Eval] $command 0]]
} else {
set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
}
foreach {actualAnswer returnCode} $testResult break
}
set code [catch {uplevel 1 $cleanup} cleanupMsg]
set cleanupFailure [expr {$code != 0}]
set coreFailure 0
set coreMsg ""
if {[preserveCore]} {
if {[file exists [file join [workingDirectory] core]]} {
if {[info exists coreModTime]} {
if {$coreModTime != [file mtime \
[file join [workingDirectory] core]]} {
set coreFailure 1
}
} else {
set coreFailure 1
}
if {([preserveCore] > 1) && ($coreFailure)} {
append coreMsg "\nMoving file to:\
[file join [temporaryDirectory] core-$name]"
catch {file rename -force \
[file join [workingDirectory] core] \
[file join [temporaryDirectory] core-$name]
} msg
if {[string length $msg] > 0} {
append coreMsg "\nError:\
Problem renaming core file: $msg"
}
}
}
}
set outputFailure 0
variable outData
if {[info exists output]} {
if {[set outputCompare [catch {
CompareStrings $outData $output $match
} outputMatch]] == 0} {
set outputFailure [expr {!$outputMatch}]
} else {
set outputFailure 1
}
}
set errorFailure 0
variable errData
if {[info exists errorOutput]} {
if {[set errorCompare [catch {
CompareStrings $errData $errorOutput $match
} errorMatch]] == 0} {
set errorFailure [expr {!$errorMatch}]
} else {
set errorFailure 1
}
}
set codeFailure 0
if {!$setupFailure && [lsearch -exact $returnCodes $returnCode] == -1} {
set codeFailure 1
}
if {$setupFailure} {
set scriptFailure 0
} elseif {[set scriptCompare [catch {
CompareStrings $actualAnswer $result $match
} scriptMatch]] == 0} {
set scriptFailure [expr {!$scriptMatch}]
} else {
set scriptFailure 1
}
variable numTests
if {!($setupFailure || $cleanupFailure || $coreFailure
|| $outputFailure || $errorFailure || $codeFailure
|| $scriptFailure)} {
if {$testLevel == 1} {
incr numTests(Passed)
if {[IsVerbose pass]} {
puts [outputChannel] "++++ $name PASSED"
}
}
incr testLevel -1
return
}
if {$testLevel == 1} {
incr numTests(Failed)
}
variable currentFailure true
if {![IsVerbose body]} {
set body ""
}
puts [outputChannel] "\n==== $name\
[string trim $description] FAILED"
if {[string length $body]} {
puts [outputChannel] "==== Contents of test case:"
puts [outputChannel] $body
}
if {$setupFailure} {
puts [outputChannel] "---- Test setup\
failed:\n$setupMsg"
}
if {$scriptFailure} {
if {$scriptCompare} {
puts [outputChannel] "---- Error testing result: $scriptMatch"
} else {
puts [outputChannel] "---- Result was:\n$actualAnswer"
puts [outputChannel] "---- Result should have been\
($match matching):\n$result"
}
}
if {$codeFailure} {
switch -- $returnCode {
0 { set msg "Test completed normally" }
1 { set msg "Test generated error" }
2 { set msg "Test generated return exception" }
3 { set msg "Test generated break exception" }
4 { set msg "Test generated continue exception" }
default { set msg "Test generated exception" }
}
puts [outputChannel] "---- $msg; Return code was: $returnCode"
puts [outputChannel] "---- Return code should have been\
one of: $returnCodes"
if {[IsVerbose error]} {
if {[info exists ::errorInfo]} {
puts [outputChannel] "---- errorInfo: $::errorInfo"
puts [outputChannel] "---- errorCode: $::errorCode"
}
}
}
if {$outputFailure} {
if {$outputCompare} {
puts [outputChannel] "---- Error testing output: $outputMatch"
} else {
puts [outputChannel] "---- Output was:\n$outData"
puts [outputChannel] "---- Output should have been\
($match matching):\n$output"
}
}
if {$errorFailure} {
if {$errorCompare} {
puts [outputChannel] "---- Error testing errorOutput: $errorMatch"
} else {
puts [outputChannel] "---- Error output was:\n$errData"
puts [outputChannel] "---- Error output should have\
been ($match matching):\n$errorOutput"
}
}
if {$cleanupFailure} {
puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
}
if {$coreFailure} {
puts [outputChannel] "---- Core file produced while running\
test! $coreMsg"
}
puts [outputChannel] "==== $name FAILED\n"
incr testLevel -1
return
}
proc tcltest::Skipped {name constraints} {
variable testLevel
variable numTests
variable testConstraints
if {$testLevel == 1} {
incr numTests(Total)
}
foreach pattern [skip] {
if {[string match $pattern $name]} {
if {$testLevel == 1} {
incr numTests(Skipped)
DebugDo 1 {AddToSkippedBecause userSpecifiedSkip}
}
return 1
}
}
set ok 0
foreach pattern [match] {
if {[string match $pattern $name]} {
set ok 1
break
}
}
if {!$ok} {
if {$testLevel == 1} {
incr numTests(Skipped)
DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch}
}
return 1
}
if {[string equal {} $constraints]} {
if {[limitConstraints]} {
AddToSkippedBecause userSpecifiedLimitConstraint
if {$testLevel == 1} {
incr numTests(Skipped)
}
return 1
}
} else {
set doTest 0
if {[string match {*[$\[]*} $constraints] != 0} {
catch {set doTest [uplevel } elseif {[regexp {[^.a-zA-Z0-9 \n\r\t]+} $constraints] != 0} {
regsub -all {[.\w]+} $constraints {$testConstraints(&)} c
catch {set doTest [eval expr $c]}
} elseif {![catch {llength $constraints}]} {
set doTest 1
foreach constraint $constraints {
if {(![info exists testConstraints($constraint)]) \
|| (!$testConstraints($constraint))} {
set doTest 0
set constraints $constraint
break
}
}
}
if {$doTest == 0} {
if {[IsVerbose skip]} {
puts [outputChannel] "++++ $name SKIPPED: $constraints"
}
if {$testLevel == 1} {
incr numTests(Skipped)
AddToSkippedBecause $constraints
}
return 1
}
}
return 0
}
proc tcltest::RunTest {name script} {
DebugPuts 3 "Running $name {$script}"
if {[llength [info commands memory]] == 1} {
memory tag $name
}
set code [catch {uplevel 1 $script} actualAnswer]
return [list $actualAnswer $code]
}
if {[llength [info commands tcltest::cleanupTestsHook]] == 0} {
proc tcltest::cleanupTestsHook {} {}
}
proc tcltest::cleanupTests {{calledFromAllFile 0}} {
variable filesMade
variable filesExisted
variable createdNewFiles
variable testSingleFile
variable numTests
variable numTestFiles
variable failFiles
variable skippedBecause
variable currentFailure
variable originalEnv
variable originalTclPlatform
variable coreModTime
FillFilesExisted
set testFileName [file tail [info script]]
cleanupTestsHook
if {!$calledFromAllFile} {
foreach file $filesMade {
if {[file exists $file]} {
DebugDo 1 {Warn "cleanupTests deleting $file..."}
catch {file delete -force $file}
}
}
set currentFiles {}
foreach file [glob -nocomplain \
-directory [temporaryDirectory] *] {
lappend currentFiles [file tail $file]
}
set newFiles {}
foreach file $currentFiles {
if {[lsearch -exact $filesExisted $file] == -1} {
lappend newFiles $file
}
}
set filesExisted $currentFiles
if {[llength $newFiles] > 0} {
set createdNewFiles($testFileName) $newFiles
}
}
if {$calledFromAllFile || $testSingleFile} {
puts -nonewline [outputChannel] "$testFileName:"
foreach index [list "Total" "Passed" "Skipped" "Failed"] {
puts -nonewline [outputChannel] \
"\t$index\t$numTests($index)"
}
puts [outputChannel] ""
if {$calledFromAllFile} {
puts [outputChannel] \
"Sourced $numTestFiles Test Files."
set numTestFiles 0
if {[llength $failFiles] > 0} {
puts [outputChannel] \
"Files with failing tests: $failFiles"
set failFiles {}
}
}
set constraintList [array names skippedBecause]
if {[llength $constraintList] > 0} {
puts [outputChannel] \
"Number of tests skipped for each constraint:"
foreach constraint [lsort $constraintList] {
puts [outputChannel] \
"\t$skippedBecause($constraint)\t$constraint"
unset skippedBecause($constraint)
}
}
set testFilesThatTurded [lsort [array names createdNewFiles]]
if {[llength $testFilesThatTurded] > 0} {
puts [outputChannel] "Warning: files left behind:"
foreach testFile $testFilesThatTurded {
puts [outputChannel] \
"\t$testFile:\t$createdNewFiles($testFile)"
unset createdNewFiles($testFile)
}
}
set filesMade {}
foreach index [list "Total" "Passed" "Skipped" "Failed"] {
set numTests($index) 0
}
if {![catch {package present Tk}] && ![testConstraint interactive]} {
exit
}
} else {
incr numTestFiles
if {$currentFailure \
&& ([lsearch -exact $failFiles $testFileName] == -1)} {
lappend failFiles $testFileName
}
set currentFailure false
set newEnv {}
set changedEnv {}
set removedEnv {}
foreach index [array names ::env] {
if {![info exists originalEnv($index)]} {
lappend newEnv $index
unset ::env($index)
} else {
if {$::env($index) != $originalEnv($index)} {
lappend changedEnv $index
set ::env($index) $originalEnv($index)
}
}
}
foreach index [array names originalEnv] {
if {![info exists ::env($index)]} {
lappend removedEnv $index
set ::env($index) $originalEnv($index)
}
}
if {[llength $newEnv] > 0} {
puts [outputChannel] \
"env array elements created:\t$newEnv"
}
if {[llength $changedEnv] > 0} {
puts [outputChannel] \
"env array elements changed:\t$changedEnv"
}
if {[llength $removedEnv] > 0} {
puts [outputChannel] \
"env array elements removed:\t$removedEnv"
}
set changedTclPlatform {}
foreach index [array names originalTclPlatform] {
if {$::tcl_platform($index) \
!= $originalTclPlatform($index)} {
lappend changedTclPlatform $index
set ::tcl_platform($index) $originalTclPlatform($index)
}
}
if {[llength $changedTclPlatform] > 0} {
puts [outputChannel] "tcl_platform array elements\
changed:\t$changedTclPlatform"
}
if {[file exists [file join [workingDirectory] core]]} {
if {[preserveCore] > 1} {
puts "rename core file (> 1)"
puts [outputChannel] "produced core file! \
Moving file to: \
[file join [temporaryDirectory] core-$name]"
catch {file rename -force \
[file join [workingDirectory] core] \
[file join [temporaryDirectory] core-$name]
} msg
if {[string length $msg] > 0} {
PrintError "Problem renaming file: $msg"
}
} else {
if {[info exists coreModTime]} {
if {$coreModTime != [file mtime \
[file join [workingDirectory] core]]} {
puts [outputChannel] "A core file was created!"
}
} else {
puts [outputChannel] "A core file was created!"
}
}
}
}
flush [outputChannel]
flush [errorChannel]
return
}
proc tcltest::getMatchingFiles args {eval GetMatchingFiles $args}
proc tcltest::GetMatchingFiles { args } {
if {[llength $args]} {
set dirList $args
} else {
set dirList [list [testsDirectory]]
}
set matchingFiles [list]
foreach directory $dirList {
set matchFileList [list]
foreach match [matchFiles] {
set matchFileList [concat $matchFileList \
[glob -directory $directory -nocomplain -- $match]]
}
set skipFileList [list]
foreach skip [skipFiles] {
set skipFileList [concat $skipFileList \
[glob -directory $directory -nocomplain -- $skip]]
}
foreach file $matchFileList {
if {[lsearch -exact $skipFileList $file] == -1} {
lappend matchingFiles $file
}
}
}
if {[llength $matchingFiles] == 0} {
PrintError "No test files remain after applying your match and\
skip patterns!"
}
return $matchingFiles
}
proc tcltest::GetMatchingDirectories {rootdir} {
set skipDirs [list $rootdir]
foreach pattern [skipDirectories] {
foreach path [glob -directory $rootdir -nocomplain -- $pattern] {
if {[file isdirectory $path]} {
lappend skipDirs $path
}
}
}
set matchDirs [list]
foreach pattern [matchDirectories] {
foreach path [glob -directory $rootdir -nocomplain -- $pattern] {
if {[file isdirectory $path]} {
if {[lsearch -exact $skipDirs $path] == -1} {
set matchDirs [concat $matchDirs \
[GetMatchingDirectories $path]]
if {[file exists [file join $path all.tcl]]} {
lappend matchDirs $path
}
}
}
}
}
if {[llength $matchDirs] == 0} {
DebugPuts 1 "No test directories remain after applying match\
and skip patterns!"
}
return $matchDirs
}
proc tcltest::runAllTests { {shell ""} } {
variable testSingleFile
variable numTestFiles
variable numTests
variable failFiles
FillFilesExisted
if {[llength [info level 0]] == 1} {
set shell [interpreter]
}
set testSingleFile false
puts [outputChannel] "Tests running in interp: $shell"
puts [outputChannel] "Tests located in: [testsDirectory]"
puts [outputChannel] "Tests running in: [workingDirectory]"
puts [outputChannel] "Temporary files stored in\
[temporaryDirectory]"
if {![catch {file system [testsDirectory]} result]
&& ![string equal native [lindex $result 0]]} {
singleProcess 1
}
if {[singleProcess]} {
puts [outputChannel] \
"Test files sourced into current interpreter"
} else {
puts [outputChannel] \
"Test files run in separate interpreters"
}
if {[llength [skip]] > 0} {
puts [outputChannel] "Skipping tests that match: [skip]"
}
puts [outputChannel] "Running tests that match: [match]"
if {[llength [skipFiles]] > 0} {
puts [outputChannel] \
"Skipping test files that match: [skipFiles]"
}
if {[llength [matchFiles]] > 0} {
puts [outputChannel] \
"Only running test files that match: [matchFiles]"
}
set timeCmd {clock format [clock seconds]}
puts [outputChannel] "Tests began at [eval $timeCmd]"
foreach file [lsort [GetMatchingFiles]] {
set tail [file tail $file]
puts [outputChannel] $tail
flush [outputChannel]
if {[singleProcess]} {
incr numTestFiles
uplevel 1 [list ::source $file]
} else {
set childargv [list]
foreach opt [Configure] {
if {[string equal $opt -outfile]} {continue}
lappend childargv $opt [Configure $opt]
}
set cmd [linsert $childargv 0 | $shell $file]
if {[catch {
incr numTestFiles
set pipeFd [open $cmd "r"]
while {[gets $pipeFd line] >= 0} {
if {[regexp [join {
{^([^:]+):\t}
{Total\t([0-9]+)\t}
{Passed\t([0-9]+)\t}
{Skipped\t([0-9]+)\t}
{Failed\t([0-9]+)}
} ""] $line null testFile \
Total Passed Skipped Failed]} {
foreach index {Total Passed Skipped Failed} {
incr numTests($index) [set $index]
}
if {$Failed > 0} {
lappend failFiles $testFile
}
} elseif {[regexp [join {
{^Number of tests skipped }
{for each constraint:}
{|^\t(\d+)\t(.+)$}
} ""] $line match skipped constraint]} {
if {[string match \t* $match]} {
AddToSkippedBecause $constraint $skipped
}
} else {
puts [outputChannel] $line
}
}
close $pipeFd
} msg]} {
puts [outputChannel] "Test file error: $msg"
lappend testFileFailures $file
}
}
}
puts [outputChannel] "\nTests ended at [eval $timeCmd]"
cleanupTests 1
if {[info exists testFileFailures]} {
puts [outputChannel] "\nTest files exiting with errors: \n"
foreach file $testFileFailures {
puts [outputChannel] " [file tail $file]\n"
}
}
foreach directory [GetMatchingDirectories [testsDirectory]] {
set dir [file tail $directory]
puts [outputChannel] [string repeat ~ 44]
puts [outputChannel] "$dir test began at [eval $timeCmd]\n"
uplevel 1 [list ::source [file join $directory all.tcl]]
set endTime [eval $timeCmd]
puts [outputChannel] "\n$dir test ended at $endTime"
puts [outputChannel] ""
puts [outputChannel] [string repeat ~ 44]
}
return
}
proc tcltest::loadTestedCommands {} {
variable l
if {[string equal {} [loadScript]]} {
return
}
return [uplevel 1 [loadScript]]
}
proc tcltest::saveState {} {
variable saveState
uplevel 1 [list ::set [namespace which -variable saveState]] \
{[::list [::info procs] [::info vars]]}
DebugPuts 2 "[lindex [info level 0] 0]: $saveState"
return
}
proc tcltest::restoreState {} {
variable saveState
foreach p [uplevel 1 {::info procs}] {
if {([lsearch [lindex $saveState 0] $p] < 0)
&& ![string equal [namespace current]::$p \
[uplevel 1 [list ::namespace origin $p]]]} {
DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p"
uplevel 1 [list ::catch [list ::rename $p {}]]
}
}
foreach p [uplevel 1 {::info vars}] {
if {[lsearch [lindex $saveState 1] $p] < 0} {
DebugPuts 2 "[lindex [info level 0] 0]:\
Removing variable $p"
uplevel 1 [list ::catch [list ::unset $p]]
}
}
return
}
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 {directory ""}} {
variable filesMade
FillFilesExisted
if {[llength [info level 0]] == 3} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]:\
putting ``$contents'' into $fullName"
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 $filesMade $fullName] == -1} {
lappend filesMade $fullName
}
return $fullName
}
proc tcltest::removeFile {name {directory ""}} {
variable filesMade
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
set idx [lsearch -exact $filesMade $fullName]
set filesMade [lreplace $filesMade $idx $idx]
if {$idx == -1} {
DebugDo 1 {
Warn "removeFile removing \"$fullName\":\n not created by makeFile"
}
}
if {![file isfile $fullName]} {
DebugDo 1 {
Warn "removeFile removing \"$fullName\":\n not a file"
}
}
return [file delete $fullName]
}
proc tcltest::makeDirectory {name {directory ""}} {
variable filesMade
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName"
file mkdir $fullName
if {[lsearch -exact $filesMade $fullName] == -1} {
lappend filesMade $fullName
}
return $fullName
}
proc tcltest::removeDirectory {name {directory ""}} {
variable filesMade
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName"
set idx [lsearch -exact $filesMade $fullName]
set filesMade [lreplace $filesMade $idx $idx]
if {$idx == -1} {
DebugDo 1 {
Warn "removeDirectory removing \"$fullName\":\n not created\
by makeDirectory"
}
}
if {![file isdirectory $fullName]} {
DebugDo 1 {
Warn "removeDirectory removing \"$fullName\":\n not a directory"
}
}
return [file delete -force $fullName]
}
proc tcltest::viewFile {name {directory ""}} {
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
set f [open $fullName]
set data [read -nonewline $f]
close $f
return $data
}
proc tcltest::bytestring {string} {
return [encoding convertfrom identity $string]
}
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::SetIso8859_1_Locale {} {
variable previousLocale
variable isoLocale
if {[info commands testlocale] != ""} {
set previousLocale [testlocale ctype]
testlocale ctype $isoLocale
}
return
}
proc tcltest::RestoreLocale {} {
variable previousLocale
if {[info commands testlocale] != ""} {
testlocale ctype $previousLocale
}
return
}
proc tcltest::threadReap {} {
if {[info commands testthread] != {}} {
testthread errorproc ThreadNullError
while {[llength [testthread names]] > 1} {
foreach tid [testthread names] {
if {$tid != [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 != [mainThread]} {
catch {thread::send -async $tid {thread::exit}}
}
}
after 1
}
thread::errorproc ThreadError
return [llength [thread::names]]
} else {
return 1
}
return 0
}
namespace eval tcltest {
DefineConstraintInitializers
trace variable testConstraints r [namespace code SafeFetch]
if {[string equal [namespace current] \
[namespace qualifiers [namespace which initConstraintsHook]]]} {
InitConstraints
} else {
proc initConstraintsHook {} {}
}
customMatch exact [list string equal]
customMatch glob [list string match]
customMatch regexp [list regexp --]
proc ConfigureFromEnvironment {} {
upvar if {[catch {llength $options} msg]} {
Warn "invalid TCLTEST_OPTIONS \"$options\":\n invalid\
Tcl list: $msg"
return
}
if {[llength $::env(TCLTEST_OPTIONS)] < 2} {
Warn "invalid TCLTEST_OPTIONS: \"$options\":\n should be\
-option value ?-option value ...?"
return
}
if {[catch {eval Configure $::env(TCLTEST_OPTIONS)} msg]} {
Warn "invalid TCLTEST_OPTIONS: \"$options\":\n $msg"
return
}
}
if {[info exists ::env(TCLTEST_OPTIONS)]} {
ConfigureFromEnvironment
}
proc LoadTimeCmdLineArgParsingRequired {} {
set required false
if {[info exists ::argv] && [lsearch -exact $::argv -help] != -1} {
set required true
}
foreach hook { PrintUsageInfoHook processCmdLineArgsHook
processCmdLineArgsAddFlagsHook } {
if {[string equal [namespace current] [namespace qualifiers \
[namespace which $hook]]]} {
set required true
} else {
proc $hook args {}
}
}
return $required
}
if {[LoadTimeCmdLineArgParsingRequired]} {
ProcessCmdLineArgs
} else {
EstablishAutoConfigureTraces
}
package provide [namespace tail [namespace current]] $Version
}