os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/tcltest.test
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/tcltest.test Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,1804 @@
1.4 +# This file contains a collection of tests for one or more of the Tcl
1.5 +# built-in commands. Sourcing this file into Tcl runs the tests and
1.6 +# generates output for errors. No output means no errors were found.
1.7 +#
1.8 +# Copyright (c) 1998-1999 by Scriptics Corporation.
1.9 +# Copyright (c) 2000 by Ajuba Solutions
1.10 +# All rights reserved.
1.11 +#
1.12 +# RCS: @(#) $Id: tcltest.test,v 1.37.2.11 2006/03/19 22:47:30 vincentdarley Exp $
1.13 +
1.14 +# Note that there are several places where the value of
1.15 +# tcltest::currentFailure is stored/reset in the -setup/-cleanup
1.16 +# of a test that has a body that runs [test] that will fail.
1.17 +# This is a workaround of using the same tcltest code that we are
1.18 +# testing to run the test itself. Ditto on things like [verbose].
1.19 +#
1.20 +# It would be better to have the -body of the tests run the tcltest
1.21 +# commands in a slave interp so the [test] being tested would not
1.22 +# interfere with the [test] doing the testing.
1.23 +#
1.24 +
1.25 +if {[catch {package require tcltest 2.1}]} {
1.26 + puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
1.27 + return
1.28 +}
1.29 +
1.30 +namespace eval ::tcltest::test {
1.31 +
1.32 +namespace import ::tcltest::*
1.33 +
1.34 +makeFile {
1.35 + package require tcltest
1.36 + namespace import ::tcltest::test
1.37 + test a-1.0 {test a} {
1.38 + list 0
1.39 + } {0}
1.40 + test b-1.0 {test b} {
1.41 + list 1
1.42 + } {0}
1.43 + test c-1.0 {test c} {knownBug} {
1.44 + } {}
1.45 + test d-1.0 {test d} {
1.46 + error "foo" foo 9
1.47 + } {}
1.48 + tcltest::cleanupTests
1.49 + exit
1.50 +} test.tcl
1.51 +
1.52 +cd [temporaryDirectory]
1.53 +testConstraint exec [llength [info commands exec]]
1.54 +# test -help
1.55 +# Child processes because -help [exit]s.
1.56 +test tcltest-1.1 {tcltest -help} {exec} {
1.57 + set result [catch {exec [interpreter] test.tcl -help} msg]
1.58 + list $result [regexp Usage $msg]
1.59 +} {1 1}
1.60 +test tcltest-1.2 {tcltest -help -something} {exec} {
1.61 + set result [catch {exec [interpreter] test.tcl -help -something} msg]
1.62 + list $result [regexp Usage $msg]
1.63 +} {1 1}
1.64 +test tcltest-1.3 {tcltest -h} {exec} {
1.65 + set result [catch {exec [interpreter] test.tcl -h} msg]
1.66 + list $result [regexp Usage $msg]
1.67 +} {1 0}
1.68 +
1.69 +# -verbose, implicit & explicit testing of [verbose]
1.70 +proc slave {msgVar args} {
1.71 + upvar 1 $msgVar msg
1.72 +
1.73 + interp create [namespace current]::i
1.74 + # Fake the slave interp into dumping output to a file
1.75 + i eval {namespace eval ::tcltest {}}
1.76 + i eval "set tcltest::outputChannel\
1.77 + \[[list open [set of [makeFile {} output]] w]]"
1.78 + i eval "set tcltest::errorChannel\
1.79 + \[[list open [set ef [makeFile {} error]] w]]"
1.80 + i eval [list set argv0 [lindex $args 0]]
1.81 + i eval [list set argv [lrange $args 1 end]]
1.82 + i eval [list package ifneeded tcltest [package provide tcltest] \
1.83 + [package ifneeded tcltest [package provide tcltest]]]
1.84 + i eval {proc exit args {}}
1.85 +
1.86 + # Need to capture output in msg
1.87 +
1.88 + set code [catch {i eval {source $argv0}} foo]
1.89 +if $code {
1.90 +#puts "$code: $foo\n$::errorInfo"
1.91 +}
1.92 + i eval {close $tcltest::outputChannel}
1.93 + interp delete [namespace current]::i
1.94 + set f [open $of]
1.95 + set msg [read -nonewline $f]
1.96 + close $f
1.97 + set f [open $ef]
1.98 + set err [read -nonewline $f]
1.99 + close $f
1.100 + removeFile output
1.101 + removeFile error
1.102 + if {[string length $err]} {
1.103 + set code 1
1.104 + append msg \n$err
1.105 + }
1.106 + return $code
1.107 +
1.108 +# return [catch {uplevel 1 [linsert $args 0 exec [interpreter]]} msg]
1.109 +}
1.110 +test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} {
1.111 + set result [slave msg test.tcl]
1.112 + list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
1.113 + [regexp c-1.0 $msg] \
1.114 + [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
1.115 +} {0 1 0 0 1}
1.116 +test tcltest-2.1 {tcltest -verbose 'b'} {unixOrPc} {
1.117 + set result [slave msg test.tcl -verbose 'b']
1.118 + list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
1.119 + [regexp c-1.0 $msg] \
1.120 + [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
1.121 +} {0 1 0 0 1}
1.122 +test tcltest-2.2 {tcltest -verbose 'p'} {unixOrPc} {
1.123 + set result [slave msg test.tcl -verbose 'p']
1.124 + list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
1.125 + [regexp c-1.0 $msg] \
1.126 + [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
1.127 +} {0 0 1 0 1}
1.128 +test tcltest-2.3 {tcltest -verbose 's'} {unixOrPc} {
1.129 + set result [slave msg test.tcl -verbose 's']
1.130 + list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
1.131 + [regexp c-1.0 $msg] \
1.132 + [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
1.133 +} {0 0 0 1 1}
1.134 +test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrPc} {
1.135 + set result [slave msg test.tcl -verbose 'ps']
1.136 + list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
1.137 + [regexp c-1.0 $msg] \
1.138 + [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
1.139 +} {0 0 1 1 1}
1.140 +test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrPc} {
1.141 + set result [slave msg test.tcl -verbose 'psb']
1.142 + list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
1.143 + [regexp c-1.0 $msg] \
1.144 + [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
1.145 +} {0 1 1 1 1}
1.146 +
1.147 +test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} {
1.148 + set result [slave msg test.tcl -verbose "pass skip body"]
1.149 + list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
1.150 + [regexp c-1.0 $msg] \
1.151 + [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
1.152 +} {0 1 1 1 1}
1.153 +
1.154 +test tcltest-2.6 {tcltest -verbose 't'} {
1.155 + -constraints {unixOrPc}
1.156 + -body {
1.157 + set result [slave msg test.tcl -verbose 't']
1.158 + list $result $msg
1.159 + }
1.160 + -result {^0 .*a-1.0 start.*b-1.0 start}
1.161 + -match regexp
1.162 +}
1.163 +
1.164 +test tcltest-2.6a {tcltest -verbose 'start'} {
1.165 + -constraints {unixOrPc}
1.166 + -body {
1.167 + set result [slave msg test.tcl -verbose start]
1.168 + list $result $msg
1.169 + }
1.170 + -result {^0 .*a-1.0 start.*b-1.0 start}
1.171 + -match regexp
1.172 +}
1.173 +
1.174 +test tcltest-2.7 {tcltest::verbose} {
1.175 + -body {
1.176 + set oldVerbosity [verbose]
1.177 + verbose bar
1.178 + set currentVerbosity [verbose]
1.179 + verbose foo
1.180 + set newVerbosity [verbose]
1.181 + verbose $oldVerbosity
1.182 + list $currentVerbosity $newVerbosity
1.183 + }
1.184 + -result {body {}}
1.185 +}
1.186 +
1.187 +test tcltest-2.8 {tcltest -verbose 'error'} {
1.188 + -constraints {unixOrPc}
1.189 + -body {
1.190 + set result [slave msg test.tcl -verbose error]
1.191 + list $result $msg
1.192 + }
1.193 + -result {errorInfo: foo.*errorCode: 9}
1.194 + -match regexp
1.195 +}
1.196 +# -match, [match]
1.197 +test tcltest-3.1 {tcltest -match 'a*'} {unixOrPc} {
1.198 + set result [slave msg test.tcl -match a* -verbose 'ps']
1.199 + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
1.200 + [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
1.201 +} {0 1 0 0 1}
1.202 +test tcltest-3.2 {tcltest -match 'b*'} {unixOrPc} {
1.203 + set result [slave msg test.tcl -match b* -verbose 'ps']
1.204 + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
1.205 + [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
1.206 +} {0 0 1 0 1}
1.207 +test tcltest-3.3 {tcltest -match 'c*'} {unixOrPc} {
1.208 + set result [slave msg test.tcl -match c* -verbose 'ps']
1.209 + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
1.210 + [regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg]
1.211 +} {0 0 0 1 1}
1.212 +test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrPc} {
1.213 + set result [slave msg test.tcl -match {a* b*} -verbose 'ps']
1.214 + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
1.215 + [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
1.216 +} {0 1 1 0 1}
1.217 +
1.218 +test tcltest-3.5 {tcltest::match} {
1.219 + -body {
1.220 + set oldMatch [match]
1.221 + match foo
1.222 + set currentMatch [match]
1.223 + match bar
1.224 + set newMatch [match]
1.225 + match $oldMatch
1.226 + list $currentMatch $newMatch
1.227 + }
1.228 + -result {foo bar}
1.229 +}
1.230 +
1.231 +# -skip, [skip]
1.232 +test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} {
1.233 + set result [slave msg test.tcl -skip a* -verbose 'ps']
1.234 + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
1.235 + [regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg]
1.236 +} {0 0 1 1 1}
1.237 +test tcltest-4.2 {tcltest -skip 'b*'} {unixOrPc} {
1.238 + set result [slave msg test.tcl -skip b* -verbose 'ps']
1.239 + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
1.240 + [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
1.241 +} {0 1 0 1 1}
1.242 +test tcltest-4.3 {tcltest -skip 'c*'} {unixOrPc} {
1.243 + set result [slave msg test.tcl -skip c* -verbose 'ps']
1.244 + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
1.245 + [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
1.246 +} {0 1 1 0 1}
1.247 +test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrPc} {
1.248 + set result [slave msg test.tcl -skip {a* b*} -verbose 'ps']
1.249 + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
1.250 + [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
1.251 +} {0 0 0 1 1}
1.252 +test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrPc} {
1.253 + set result [slave msg test.tcl -match {a* b*} -skip b* -verbose 'ps']
1.254 + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
1.255 + [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
1.256 +} {0 1 0 0 1}
1.257 +
1.258 +test tcltest-4.6 {tcltest::skip} {
1.259 + -body {
1.260 + set oldSkip [skip]
1.261 + skip foo
1.262 + set currentSkip [skip]
1.263 + skip bar
1.264 + set newSkip [skip]
1.265 + skip $oldSkip
1.266 + list $currentSkip $newSkip
1.267 + }
1.268 + -result {foo bar}
1.269 +}
1.270 +
1.271 +# -constraints, -limitconstraints, [testConstraint],
1.272 +# $constraintsSpecified, [limitConstraints]
1.273 +test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} {
1.274 + set result [slave msg test.tcl -constraints knownBug -verbose 'ps']
1.275 + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
1.276 + [regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg]
1.277 +} {0 1 1 1 1}
1.278 +test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrPc} {
1.279 + set result [slave msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1]
1.280 + list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
1.281 + [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
1.282 +} {0 0 0 1 1}
1.283 +
1.284 +test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)} {
1.285 + -body {
1.286 + set r1 [testConstraint tcltestFakeConstraint]
1.287 + set r2 [testConstraint tcltestFakeConstraint 4]
1.288 + set r3 [testConstraint tcltestFakeConstraint]
1.289 + list $r1 $r2 $r3
1.290 + }
1.291 + -result {0 4 4}
1.292 + -cleanup {unset ::tcltest::testConstraints(tcltestFakeConstraint)}
1.293 +}
1.294 +
1.295 +# Removed this test of internals of tcltest. Those internals have changed.
1.296 +#test tcltest-5.4 {tcltest::constraintsSpecified} {
1.297 +# -setup {
1.298 +# set constraintlist $::tcltest::constraintsSpecified
1.299 +# set ::tcltest::constraintsSpecified {}
1.300 +# }
1.301 +# -body {
1.302 +# set r1 $::tcltest::constraintsSpecified
1.303 +# testConstraint tcltestFakeConstraint1 1
1.304 +# set r2 $::tcltest::constraintsSpecified
1.305 +# testConstraint tcltestFakeConstraint2 1
1.306 +# set r3 $::tcltest::constraintsSpecified
1.307 +# list $r1 $r2 $r3
1.308 +# }
1.309 +# -result {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}}
1.310 +# -cleanup {
1.311 +# set ::tcltest::constraintsSpecified $constraintlist
1.312 +# unset ::tcltest::testConstraints(tcltestFakeConstraint1)
1.313 +# unset ::tcltest::testConstraints(tcltestFakeConstraint2)
1.314 +# }
1.315 +#}
1.316 +
1.317 +test tcltest-5.5 {InitConstraints: list of built-in constraints} \
1.318 + -constraints {!singleTestInterp} \
1.319 + -setup {tcltest::InitConstraints} \
1.320 + -body { lsort [array names ::tcltest::testConstraints] } \
1.321 + -result [lsort {
1.322 + 95 98 asyncPipeClose eformat emptyTest exec hasIsoLocale interactive
1.323 + knownBug mac macCrash macOnly macOrPc macOrUnix macOrWin nonBlockFiles
1.324 + nonPortable notRoot nt pc pcCrash pcOnly root singleTestInterp socket
1.325 + stdio tempNotMac tempNotPc tempNotUnix tempNotWin unix unixCrash unixExecs
1.326 + unixOnly unixOrPc unixOrWin userInteraction win winCrash winOnly
1.327 +}]
1.328 +
1.329 +# Removed this broken test. Its usage of [limitConstraints] was not
1.330 +# in agreement with the documentation. [limitConstraints] is supposed
1.331 +# to take an optional boolean argument, and "knownBug" ain't no boolean!
1.332 +#test tcltest-5.6 {tcltest::limitConstraints} {
1.333 +# -setup {
1.334 +# set keeplc $::tcltest::limitConstraints
1.335 +# set keepkb [testConstraint knownBug]
1.336 +# }
1.337 +# -body {
1.338 +# set r1 [limitConstraints]
1.339 +# set r2 [limitConstraints knownBug]
1.340 +# set r3 [limitConstraints]
1.341 +# list $r1 $r2 $r3
1.342 +# }
1.343 +# -cleanup {
1.344 +# limitConstraints $keeplc
1.345 +# testConstraint knownBug $keepkb
1.346 +# }
1.347 +# -result {false knownBug knownBug}
1.348 +#}
1.349 +
1.350 +# -outfile, -errfile, [outputChannel], [outputFile], [errorChannel], [errorFile]
1.351 +set printerror [makeFile {
1.352 + package require tcltest
1.353 + namespace import ::tcltest::*
1.354 + puts [outputChannel] "a test"
1.355 + ::tcltest::PrintError "a really short string"
1.356 + ::tcltest::PrintError "a really really really really really really long \
1.357 + string containing \"quotes\" and other bad bad stuff"
1.358 + ::tcltest::PrintError "a really really long string containing a \
1.359 + \"Path/that/is/really/long/and/contains/no/spaces\""
1.360 + ::tcltest::PrintError "a really really long string containing a \
1.361 + \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\""
1.362 + ::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\""
1.363 + exit
1.364 +} printerror.tcl]
1.365 +
1.366 +test tcltest-6.1 {tcltest -outfile, -errfile defaults} {
1.367 + -constraints unixOrPc
1.368 + -body {
1.369 + slave msg $printerror
1.370 + return $msg
1.371 + }
1.372 + -result {a test.*a really}
1.373 + -match regexp
1.374 +}
1.375 +test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} {
1.376 + slave msg $printerror -outfile a.tmp
1.377 + set result1 [catch {exec grep "a test" a.tmp}]
1.378 + set result2 [catch {exec grep "a really" a.tmp}]
1.379 + list [regexp "a test" $msg] [regexp "a really" $msg] \
1.380 + $result1 $result2 [file exists a.tmp] [file delete a.tmp]
1.381 +} {0 1 0 1 1 {}}
1.382 +test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} {
1.383 + slave msg $printerror -errfile a.tmp
1.384 + set result1 [catch {exec grep "a test" a.tmp}]
1.385 + set result2 [catch {exec grep "a really" a.tmp}]
1.386 + list [regexp "a test" $msg] [regexp "a really" $msg] \
1.387 + $result1 $result2 [file exists a.tmp] [file delete a.tmp]
1.388 +} {1 0 1 0 1 {}}
1.389 +test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrPc unixExecs} {
1.390 + slave msg $printerror -outfile a.tmp -errfile b.tmp
1.391 + set result1 [catch {exec grep "a test" a.tmp}]
1.392 + set result2 [catch {exec grep "a really" b.tmp}]
1.393 + list [regexp "a test" $msg] [regexp "a really" $msg] \
1.394 + $result1 $result2 \
1.395 + [file exists a.tmp] [file delete a.tmp] \
1.396 + [file exists b.tmp] [file delete b.tmp]
1.397 +} {0 0 0 0 1 {} 1 {}}
1.398 +
1.399 +test tcltest-6.5 {tcltest::errorChannel - retrieval} {
1.400 + -setup {
1.401 + set of [errorChannel]
1.402 + set ::tcltest::errorChannel stderr
1.403 + }
1.404 + -body {
1.405 + errorChannel
1.406 + }
1.407 + -result {stderr}
1.408 + -cleanup {
1.409 + set ::tcltest::errorChannel $of
1.410 + }
1.411 +}
1.412 +
1.413 +test tcltest-6.6 {tcltest::errorFile (implicit errorChannel)} {
1.414 + -setup {
1.415 + set ef [makeFile {} efile]
1.416 + set of [errorFile]
1.417 + set ::tcltest::errorChannel stderr
1.418 + set ::tcltest::errorFile stderr
1.419 + }
1.420 + -body {
1.421 + set f0 [errorChannel]
1.422 + set f1 [errorFile]
1.423 + set f2 [errorFile $ef]
1.424 + set f3 [errorChannel]
1.425 + set f4 [errorFile]
1.426 + subst {$f0;$f1;$f2;$f3;$f4}
1.427 + }
1.428 + -result {stderr;stderr;.*efile;file[0-9a-f]+;.*efile}
1.429 + -match regexp
1.430 + -cleanup {
1.431 + errorFile $of
1.432 + removeFile efile
1.433 + }
1.434 +}
1.435 +test tcltest-6.7 {tcltest::outputChannel - retrieval} {
1.436 + -setup {
1.437 + set of [outputChannel]
1.438 + set ::tcltest::outputChannel stdout
1.439 + }
1.440 + -body {
1.441 + outputChannel
1.442 + }
1.443 + -result {stdout}
1.444 + -cleanup {
1.445 + set tcltest::outputChannel $of
1.446 + }
1.447 +}
1.448 +
1.449 +test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} {
1.450 + -setup {
1.451 + set ef [makeFile {} efile]
1.452 + set of [outputFile]
1.453 + set ::tcltest::outputChannel stdout
1.454 + set ::tcltest::outputFile stdout
1.455 + }
1.456 + -body {
1.457 + set f0 [outputChannel]
1.458 + set f1 [outputFile]
1.459 + set f2 [outputFile $ef]
1.460 + set f3 [outputChannel]
1.461 + set f4 [outputFile]
1.462 + subst {$f0;$f1;$f2;$f3;$f4}
1.463 + }
1.464 + -result {stdout;stdout;.*efile;file[0-9a-f]+;.*efile}
1.465 + -match regexp
1.466 + -cleanup {
1.467 + outputFile $of
1.468 + removeFile efile
1.469 + }
1.470 +}
1.471 +
1.472 +# -debug, [debug]
1.473 +# Must use child processes to test -debug because it always writes
1.474 +# messages to stdout, and we have no way to capture stdout of a
1.475 +# slave interp
1.476 +test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrPc} {
1.477 + catch {exec [interpreter] test.tcl -debug 0} msg
1.478 + regexp "Flags passed into tcltest" $msg
1.479 +} {0}
1.480 +test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrPc} {
1.481 + catch {exec [interpreter] test.tcl -debug 1 -skip b*} msg
1.482 + list [regexp userSpecifiedSkip $msg] \
1.483 + [regexp "Flags passed into tcltest" $msg]
1.484 +} {1 0}
1.485 +test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrPc} {
1.486 + catch {exec [interpreter] test.tcl -debug 1 -match b*} msg
1.487 + list [regexp userSpecifiedNonMatch $msg] \
1.488 + [regexp "Flags passed into tcltest" $msg]
1.489 +} {1 0}
1.490 +test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrPc} {
1.491 + catch {exec [interpreter] test.tcl -debug 2} msg
1.492 + list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
1.493 +} {1 0}
1.494 +test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrPc} {
1.495 + catch {exec [interpreter] test.tcl -debug 3} msg
1.496 + list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
1.497 +} {1 1}
1.498 +
1.499 +test tcltest-7.6 {tcltest::debug} {
1.500 + -setup {
1.501 + set old $::tcltest::debug
1.502 + set ::tcltest::debug 0
1.503 + }
1.504 + -body {
1.505 + set f1 [debug]
1.506 + set f2 [debug 1]
1.507 + set f3 [debug]
1.508 + set f4 [debug 2]
1.509 + set f5 [debug]
1.510 + list $f1 $f2 $f3 $f4 $f5
1.511 + }
1.512 + -result {0 1 1 2 2}
1.513 + -cleanup {
1.514 + set ::tcltest::debug $old
1.515 + }
1.516 +}
1.517 +removeFile test.tcl
1.518 +
1.519 +# directory tests
1.520 +
1.521 +set a [makeFile {
1.522 + package require tcltest
1.523 + tcltest::makeFile {} a.tmp
1.524 + puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]"
1.525 + exit
1.526 +} a.tcl]
1.527 +
1.528 +set tdiaf [makeFile {} thisdirectoryisafile]
1.529 +
1.530 +set normaldirectory [makeDirectory normaldirectory]
1.531 +normalizePath normaldirectory
1.532 +
1.533 +# -tmpdir, [temporaryDirectory]
1.534 +test tcltest-8.1 {tcltest a.tcl -tmpdir a} {unixOrPc} {
1.535 + file delete -force thisdirectorydoesnotexist
1.536 + slave msg $a -tmpdir thisdirectorydoesnotexist
1.537 + list [file exists [file join thisdirectorydoesnotexist a.tmp]] \
1.538 + [file delete -force thisdirectorydoesnotexist]
1.539 +} {1 {}}
1.540 +test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {
1.541 + -constraints unixOrPc
1.542 + -body {
1.543 + slave msg $a -tmpdir $tdiaf
1.544 + set msg
1.545 + }
1.546 + -result {*not a directory*}
1.547 + -match glob
1.548 +}
1.549 +
1.550 +# Test non-writeable directories, non-readable directories with directory flags
1.551 +set notReadableDir [file join [temporaryDirectory] notreadable]
1.552 +set notWriteableDir [file join [temporaryDirectory] notwriteable]
1.553 +
1.554 +makeDirectory notreadable
1.555 +makeDirectory notwriteable
1.556 +
1.557 +switch $tcl_platform(platform) {
1.558 + "unix" {
1.559 + file attributes $notReadableDir -permissions 00333
1.560 + file attributes $notWriteableDir -permissions 00555
1.561 + }
1.562 + default {
1.563 + catch {file attributes $notWriteableDir -readonly 1}
1.564 + catch {testchmod 000 $notWriteableDir}
1.565 + }
1.566 +}
1.567 +
1.568 +test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {unix notRoot} {
1.569 + slave msg $a -tmpdir $notReadableDir
1.570 + string match {*not readable*} $msg
1.571 +} {1}
1.572 +
1.573 +test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {unixOrPc notRoot} {
1.574 + slave msg $a -tmpdir $notWriteableDir
1.575 + string match {*not writeable*} $msg
1.576 +} {1}
1.577 +
1.578 +test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {unixOrPc} {
1.579 + slave msg $a -tmpdir $normaldirectory
1.580 + # The join is necessary because the message can be split on multiple lines
1.581 + list [file exists [file join $normaldirectory a.tmp]] \
1.582 + [file delete [file join $normaldirectory a.tmp]]
1.583 +} {1 {}}
1.584 +cd [workingDirectory]
1.585 +
1.586 +test tcltest-8.6 {temporaryDirectory} {
1.587 + -setup {
1.588 + set old $::tcltest::temporaryDirectory
1.589 + set ::tcltest::temporaryDirectory $normaldirectory
1.590 + }
1.591 + -body {
1.592 + set f1 [temporaryDirectory]
1.593 + set f2 [temporaryDirectory [workingDirectory]]
1.594 + set f3 [temporaryDirectory]
1.595 + list $f1 $f2 $f3
1.596 + }
1.597 + -result "[list $normaldirectory [workingDirectory] [workingDirectory]]"
1.598 + -cleanup {
1.599 + set ::tcltest::temporaryDirectory $old
1.600 + }
1.601 +}
1.602 +
1.603 +test tcltest-8.6a {temporaryDirectory - test format 2} -setup {
1.604 + set old $::tcltest::temporaryDirectory
1.605 + set ::tcltest::temporaryDirectory $normaldirectory
1.606 +} -body {
1.607 + set f1 [temporaryDirectory]
1.608 + set f2 [temporaryDirectory [workingDirectory]]
1.609 + set f3 [temporaryDirectory]
1.610 + list $f1 $f2 $f3
1.611 +} -cleanup {
1.612 + set ::tcltest::temporaryDirectory $old
1.613 +} -result [list $normaldirectory [workingDirectory] [workingDirectory]]
1.614 +
1.615 +cd [temporaryDirectory]
1.616 +# -testdir, [testsDirectory]
1.617 +test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {unixOrPc} {
1.618 + file delete -force thisdirectorydoesnotexist
1.619 + slave msg $a -testdir thisdirectorydoesnotexist
1.620 + string match "*does not exist*" $msg
1.621 +} {1}
1.622 +
1.623 +test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {unixOrPc} {
1.624 + slave msg $a -testdir $tdiaf
1.625 + string match "*not a directory*" $msg
1.626 +} {1}
1.627 +
1.628 +test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {unix notRoot} {
1.629 + slave msg $a -testdir $notReadableDir
1.630 + string match {*not readable*} $msg
1.631 +} {1}
1.632 +
1.633 +
1.634 +test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {unixOrPc} {
1.635 + slave msg $a -testdir $normaldirectory
1.636 + # The join is necessary because the message can be split on multiple lines
1.637 + list [string first "testdir: $normaldirectory" [join $msg]] \
1.638 + [file exists [file join [temporaryDirectory] a.tmp]] \
1.639 + [file delete [file join [temporaryDirectory] a.tmp]]
1.640 +} {0 1 {}}
1.641 +cd [workingDirectory]
1.642 +
1.643 +set current [pwd]
1.644 +test tcltest-8.14 {testsDirectory} {
1.645 + -setup {
1.646 + set old $::tcltest::testsDirectory
1.647 + set ::tcltest::testsDirectory $normaldirectory
1.648 + }
1.649 + -body {
1.650 + set f1 [testsDirectory]
1.651 + set f2 [testsDirectory $current]
1.652 + set f3 [testsDirectory]
1.653 + list $f1 $f2 $f3
1.654 + }
1.655 + -result "[list $normaldirectory $current $current]"
1.656 + -cleanup {
1.657 + set ::tcltest::testsDirectory $old
1.658 + }
1.659 +}
1.660 +
1.661 +# [workingDirectory]
1.662 +test tcltest-8.60 {::workingDirectory} {
1.663 + -setup {
1.664 + set old $::tcltest::workingDirectory
1.665 + set current [pwd]
1.666 + set ::tcltest::workingDirectory $normaldirectory
1.667 + cd $normaldirectory
1.668 + }
1.669 + -body {
1.670 + set f1 [workingDirectory]
1.671 + set f2 [pwd]
1.672 + set f3 [workingDirectory $current]
1.673 + set f4 [pwd]
1.674 + set f5 [workingDirectory]
1.675 + list $f1 $f2 $f3 $f4 $f5
1.676 + }
1.677 + -result "[list $normaldirectory \
1.678 + $normaldirectory \
1.679 + $current \
1.680 + $current \
1.681 + $current]"
1.682 + -cleanup {
1.683 + set ::tcltest::workingDirectory $old
1.684 + cd $current
1.685 + }
1.686 +}
1.687 +
1.688 +# clean up from directory testing
1.689 +
1.690 +switch $tcl_platform(platform) {
1.691 + "unix" {
1.692 + file attributes $notReadableDir -permissions 777
1.693 + file attributes $notWriteableDir -permissions 777
1.694 + }
1.695 + default {
1.696 + catch {file attributes $notWriteableDir -readonly 0}
1.697 + }
1.698 +}
1.699 +
1.700 +file delete -force $notReadableDir $notWriteableDir
1.701 +removeFile a.tcl
1.702 +removeFile thisdirectoryisafile
1.703 +removeDirectory normaldirectory
1.704 +
1.705 +# -file, -notfile, [matchFiles], [skipFiles]
1.706 +test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup {
1.707 + set old [testsDirectory]
1.708 + testsDirectory [file dirname [info script]]
1.709 +} -body {
1.710 + slave msg [file join [testsDirectory] all.tcl] -file d*.test
1.711 + set msg
1.712 +} -cleanup {
1.713 + testsDirectory $old
1.714 +} -match regexp -result {dstring\.test}
1.715 +
1.716 +test tcltest-9.2 {-file d*.tcl} -constraints {unixOrPc} -setup {
1.717 + set old [testsDirectory]
1.718 + testsDirectory [file dirname [info script]]
1.719 +} -body {
1.720 + slave msg [file join [testsDirectory] all.tcl] \
1.721 + -file d*.test -notfile dstring*
1.722 + regexp {dstring\.test} $msg
1.723 +} -cleanup {
1.724 + testsDirectory $old
1.725 +} -result 0
1.726 +
1.727 +test tcltest-9.3 {matchFiles} {
1.728 + -body {
1.729 + set old [matchFiles]
1.730 + matchFiles foo
1.731 + set current [matchFiles]
1.732 + matchFiles bar
1.733 + set new [matchFiles]
1.734 + matchFiles $old
1.735 + list $current $new
1.736 + }
1.737 + -result {foo bar}
1.738 +}
1.739 +
1.740 +test tcltest-9.4 {skipFiles} {
1.741 + -body {
1.742 + set old [skipFiles]
1.743 + skipFiles foo
1.744 + set current [skipFiles]
1.745 + skipFiles bar
1.746 + set new [skipFiles]
1.747 + skipFiles $old
1.748 + list $current $new
1.749 + }
1.750 + -result {foo bar}
1.751 +}
1.752 +
1.753 +test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup {
1.754 + set d [makeDirectory tmp]
1.755 + makeDirectory foo $d
1.756 + makeFile {} fee $d
1.757 + file copy [file join [file dirname [info script]] all.tcl] $d
1.758 +} -body {
1.759 + slave msg [file join [temporaryDirectory] all.tcl] -file f*
1.760 + regexp {exiting with errors:} $msg
1.761 +} -cleanup {
1.762 + file delete [file join $d all.tcl]
1.763 + removeFile fee $d
1.764 + removeDirectory foo $d
1.765 + removeDirectory tmp
1.766 +} -result 0
1.767 +
1.768 +# -preservecore, [preserveCore]
1.769 +set mc [makeFile {
1.770 + package require tcltest
1.771 + namespace import ::tcltest::test
1.772 + test makecore {make a core file} {
1.773 + set f [open core w]
1.774 + close $f
1.775 + } {}
1.776 + ::tcltest::cleanupTests
1.777 + return
1.778 +} makecore.tcl]
1.779 +
1.780 +cd [temporaryDirectory]
1.781 +test tcltest-10.1 {-preservecore 0} {unixOrPc} {
1.782 + slave msg $mc -preservecore 0
1.783 + file delete core
1.784 + regexp "Core file produced" $msg
1.785 +} {0}
1.786 +test tcltest-10.2 {-preservecore 1} {unixOrPc} {
1.787 + slave msg $mc -preservecore 1
1.788 + file delete core
1.789 + regexp "Core file produced" $msg
1.790 +} {1}
1.791 +test tcltest-10.3 {-preservecore 2} {unixOrPc} {
1.792 + slave msg $mc -preservecore 2
1.793 + file delete core
1.794 + list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
1.795 + [regexp "core-" $msg] [file delete core-makecore]
1.796 +} {1 1 1 {}}
1.797 +test tcltest-10.4 {-preservecore 3} {unixOrPc} {
1.798 + slave msg $mc -preservecore 3
1.799 + file delete core
1.800 + list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
1.801 + [regexp "core-" $msg] [file delete core-makecore]
1.802 +} {1 1 1 {}}
1.803 +
1.804 +# Removing this test. It makes no sense to test the ability of
1.805 +# [preserveCore] to accept an invalid value that will cause errors
1.806 +# in other parts of tcltest's operation.
1.807 +#test tcltest-10.5 {preserveCore} {
1.808 +# -body {
1.809 +# set old [preserveCore]
1.810 +# set result [preserveCore foo]
1.811 +# set result2 [preserveCore]
1.812 +# preserveCore $old
1.813 +# list $result $result2
1.814 +# }
1.815 +# -result {foo foo}
1.816 +#}
1.817 +removeFile makecore.tcl
1.818 +
1.819 +# -load, -loadfile, [loadScript], [loadFile]
1.820 +set contents {
1.821 + package require tcltest
1.822 + namespace import tcltest::*
1.823 + puts [outputChannel] $::tcltest::loadScript
1.824 + exit
1.825 +}
1.826 +set loadfile [makeFile $contents load.tcl]
1.827 +
1.828 +test tcltest-12.1 {-load xxx} {unixOrPc} {
1.829 + slave msg $loadfile -load xxx
1.830 + set msg
1.831 +} {xxx}
1.832 +
1.833 +# Using child process because of -debug usage.
1.834 +test tcltest-12.2 {-loadfile load.tcl} {unixOrPc} {
1.835 + catch {exec [interpreter] $loadfile -debug 2 -loadfile $loadfile} msg
1.836 + list \
1.837 + [regexp {tcltest} [join [list $msg] [split $msg \n]]] \
1.838 + [regexp {loadScript} [join [list $msg] [split $msg \n]]]
1.839 +} {1 1}
1.840 +
1.841 +test tcltest-12.3 {loadScript} {
1.842 + -setup {
1.843 + set old $::tcltest::loadScript
1.844 + set ::tcltest::loadScript {}
1.845 + }
1.846 + -body {
1.847 + set f1 [loadScript]
1.848 + set f2 [loadScript xxx]
1.849 + set f3 [loadScript]
1.850 + list $f1 $f2 $f3
1.851 + }
1.852 + -result {{} xxx xxx}
1.853 + -cleanup {
1.854 + set ::tcltest::loadScript $old
1.855 + }
1.856 +}
1.857 +
1.858 +test tcltest-12.4 {loadFile} {
1.859 + -setup {
1.860 + set olds $::tcltest::loadScript
1.861 + set ::tcltest::loadScript {}
1.862 + set oldf $::tcltest::loadFile
1.863 + set ::tcltest::loadFile {}
1.864 + }
1.865 + -body {
1.866 + set f1 [loadScript]
1.867 + set f2 [loadFile]
1.868 + set f3 [loadFile $loadfile]
1.869 + set f4 [loadScript]
1.870 + set f5 [loadFile]
1.871 + list $f1 $f2 $f3 $f4 $f5
1.872 + }
1.873 + -result "[list {} {} $loadfile $contents $loadfile]\n"
1.874 + -cleanup {
1.875 + set ::tcltest::loadScript $olds
1.876 + set ::tcltest::loadFile $oldf
1.877 + }
1.878 +}
1.879 +removeFile load.tcl
1.880 +
1.881 +# [interpreter]
1.882 +test tcltest-13.1 {interpreter} {
1.883 + -setup {
1.884 + set old $::tcltest::tcltest
1.885 + set ::tcltest::tcltest tcltest
1.886 + }
1.887 + -body {
1.888 + set f1 [interpreter]
1.889 + set f2 [interpreter tclsh]
1.890 + set f3 [interpreter]
1.891 + list $f1 $f2 $f3
1.892 + }
1.893 + -result {tcltest tclsh tclsh}
1.894 + -cleanup {
1.895 + set ::tcltest::tcltest $old
1.896 + }
1.897 +}
1.898 +
1.899 +# -singleproc, [singleProcess]
1.900 +set spd [makeDirectory singleprocdir]
1.901 +makeFile {
1.902 + set foo 1
1.903 +} single1.test $spd
1.904 +
1.905 +makeFile {
1.906 + unset foo
1.907 +} single2.test $spd
1.908 +
1.909 +set allfile [makeFile {
1.910 + package require tcltest
1.911 + namespace import tcltest::*
1.912 + testsDirectory [file join [temporaryDirectory] singleprocdir]
1.913 + runAllTests
1.914 +} all-single.tcl $spd]
1.915 +cd [workingDirectory]
1.916 +
1.917 +test tcltest-14.1 {-singleproc - single process} {
1.918 + -constraints {unixOrPc}
1.919 + -body {
1.920 + slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory]
1.921 + set msg
1.922 + }
1.923 + -result {Test file error: can't unset .foo.: no such variable}
1.924 + -match regexp
1.925 +}
1.926 +
1.927 +test tcltest-14.2 {-singleproc - multiple process} {
1.928 + -constraints {unixOrPc}
1.929 + -body {
1.930 + slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory]
1.931 + set msg
1.932 + }
1.933 + -result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0}
1.934 + -match regexp
1.935 +}
1.936 +
1.937 +test tcltest-14.3 {singleProcess} {
1.938 + -setup {
1.939 + set old $::tcltest::singleProcess
1.940 + set ::tcltest::singleProcess 0
1.941 + }
1.942 + -body {
1.943 + set f1 [singleProcess]
1.944 + set f2 [singleProcess 1]
1.945 + set f3 [singleProcess]
1.946 + list $f1 $f2 $f3
1.947 + }
1.948 + -result {0 1 1}
1.949 + -cleanup {
1.950 + set ::tcltest::singleProcess $old
1.951 + }
1.952 +}
1.953 +removeFile single1.test $spd
1.954 +removeFile single2.test $spd
1.955 +removeDirectory singleprocdir
1.956 +
1.957 +# -asidefromdir, -relateddir, [matchDirectories], [skipDirectories]
1.958 +
1.959 +# Before running these tests, need to set up test subdirectories with their own
1.960 +# all.tcl files.
1.961 +
1.962 +set dtd [makeDirectory dirtestdir]
1.963 +set dtd1 [makeDirectory dirtestdir2.1 $dtd]
1.964 +set dtd2 [makeDirectory dirtestdir2.2 $dtd]
1.965 +set dtd3 [makeDirectory dirtestdir2.3 $dtd]
1.966 +makeFile {
1.967 + package require tcltest
1.968 + namespace import -force tcltest::*
1.969 + testsDirectory [file join [temporaryDirectory] dirtestdir]
1.970 + runAllTests
1.971 +} all.tcl $dtd
1.972 +makeFile {
1.973 + package require tcltest
1.974 + namespace import -force tcltest::*
1.975 + testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.1]
1.976 + runAllTests
1.977 +} all.tcl $dtd1
1.978 +makeFile {
1.979 + package require tcltest
1.980 + namespace import -force tcltest::*
1.981 + testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.2]
1.982 + runAllTests
1.983 +} all.tcl $dtd2
1.984 +makeFile {
1.985 + package require tcltest
1.986 + namespace import -force tcltest::*
1.987 + testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3]
1.988 + runAllTests
1.989 +} all.tcl $dtd3
1.990 +
1.991 +test tcltest-15.1 {basic directory walking} {
1.992 + -constraints {unixOrPc}
1.993 + -body {
1.994 + if {[slave msg \
1.995 + [file join $dtd all.tcl] \
1.996 + -tmpdir [temporaryDirectory]] == 1} {
1.997 + error $msg
1.998 + }
1.999 + }
1.1000 + -match regexp
1.1001 + -returnCodes 1
1.1002 + -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123]}
1.1003 +}
1.1004 +
1.1005 +test tcltest-15.2 {-asidefromdir} {
1.1006 + -constraints {unixOrPc}
1.1007 + -body {
1.1008 + if {[slave msg \
1.1009 + [file join $dtd all.tcl] \
1.1010 + -asidefromdir dirtestdir2.3 \
1.1011 + -tmpdir [temporaryDirectory]] == 1} {
1.1012 + error $msg
1.1013 + }
1.1014 + }
1.1015 + -match regexp
1.1016 + -returnCodes 1
1.1017 + -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.[12].*Tests located in:.*dirtestdir2.[12].*dirtestdir2.[12] test ended at .*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1.1018 +Error: No test files remain after applying your match and skip patterns!
1.1019 +Error: No test files remain after applying your match and skip patterns!
1.1020 +Error: No test files remain after applying your match and skip patterns!$}
1.1021 +}
1.1022 +
1.1023 +test tcltest-15.3 {-relateddir, non-existent dir} {
1.1024 + -constraints {unixOrPc}
1.1025 + -body {
1.1026 + if {[slave msg \
1.1027 + [file join $dtd all.tcl] \
1.1028 + -relateddir [file join [temporaryDirectory] dirtestdir0] \
1.1029 + -tmpdir [temporaryDirectory]] == 1} {
1.1030 + error $msg
1.1031 + }
1.1032 + }
1.1033 + -returnCodes 1
1.1034 + -match regexp
1.1035 + -result {[^~]|dirtestdir[^2]}
1.1036 +}
1.1037 +
1.1038 +test tcltest-15.4 {-relateddir, subdir} {
1.1039 + -constraints {unixOrPc}
1.1040 + -body {
1.1041 + if {[slave msg \
1.1042 + [file join $dtd all.tcl] \
1.1043 + -relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} {
1.1044 + error $msg
1.1045 + }
1.1046 + }
1.1047 + -returnCodes 1
1.1048 + -match regexp
1.1049 + -result {Tests located in:.*dirtestdir2.[^23]}
1.1050 +}
1.1051 +test tcltest-15.5 {-relateddir, -asidefromdir} {
1.1052 + -constraints {unixOrPc}
1.1053 + -body {
1.1054 + if {[slave msg \
1.1055 + [file join $dtd all.tcl] \
1.1056 + -relateddir "dirtestdir2.1 dirtestdir2.2" \
1.1057 + -asidefromdir dirtestdir2.2 \
1.1058 + -tmpdir [temporaryDirectory]] == 1} {
1.1059 + error $msg
1.1060 + }
1.1061 + }
1.1062 + -match regexp
1.1063 + -returnCodes 1
1.1064 + -result {Tests located in:.*dirtestdir2.[^23]}
1.1065 +}
1.1066 +
1.1067 +test tcltest-15.6 {matchDirectories} {
1.1068 + -setup {
1.1069 + set old [matchDirectories]
1.1070 + set ::tcltest::matchDirectories {}
1.1071 + }
1.1072 + -body {
1.1073 + set r1 [matchDirectories]
1.1074 + set r2 [matchDirectories foo]
1.1075 + set r3 [matchDirectories]
1.1076 + list $r1 $r2 $r3
1.1077 + }
1.1078 + -cleanup {
1.1079 + set ::tcltest::matchDirectories $old
1.1080 + }
1.1081 + -result {{} foo foo}
1.1082 +}
1.1083 +
1.1084 +test tcltest-15.7 {skipDirectories} {
1.1085 + -setup {
1.1086 + set old [skipDirectories]
1.1087 + set ::tcltest::skipDirectories {}
1.1088 + }
1.1089 + -body {
1.1090 + set r1 [skipDirectories]
1.1091 + set r2 [skipDirectories foo]
1.1092 + set r3 [skipDirectories]
1.1093 + list $r1 $r2 $r3
1.1094 + }
1.1095 + -cleanup {
1.1096 + set ::tcltest::skipDirectories $old
1.1097 + }
1.1098 + -result {{} foo foo}
1.1099 +}
1.1100 +removeDirectory dirtestdir2.3 $dtd
1.1101 +removeDirectory dirtestdir2.2 $dtd
1.1102 +removeDirectory dirtestdir2.1 $dtd
1.1103 +removeDirectory dirtestdir
1.1104 +
1.1105 +# TCLTEST_OPTIONS
1.1106 +test tcltest-19.1 {TCLTEST_OPTIONS default} -setup {
1.1107 + if {[info exists ::env(TCLTEST_OPTIONS)]} {
1.1108 + set oldoptions $::env(TCLTEST_OPTIONS)
1.1109 + } else {
1.1110 + set oldoptions none
1.1111 + }
1.1112 + # set this to { } instead of just {} to get around quirk in
1.1113 + # Windows env handling that removes empty elements from env array.
1.1114 + set ::env(TCLTEST_OPTIONS) { }
1.1115 + interp create slave1
1.1116 + slave1 eval [list set argv {-debug 2}]
1.1117 + slave1 alias puts puts
1.1118 + interp create slave2
1.1119 + slave2 alias puts puts
1.1120 + } -cleanup {
1.1121 + interp delete slave2
1.1122 + interp delete slave1
1.1123 + if {$oldoptions == "none"} {
1.1124 + unset ::env(TCLTEST_OPTIONS)
1.1125 + } else {
1.1126 + set ::env(TCLTEST_OPTIONS) $oldoptions
1.1127 + }
1.1128 + } -body {
1.1129 + slave1 eval [package ifneeded tcltest [package provide tcltest]]
1.1130 + slave1 eval tcltest::debug
1.1131 + set ::env(TCLTEST_OPTIONS) "-debug 3"
1.1132 + slave2 eval [package ifneeded tcltest [package provide tcltest]]
1.1133 + slave2 eval tcltest::debug
1.1134 + } -result {^3$} -match regexp -output\
1.1135 +{tcltest::debug\s+= 2.*tcltest::debug\s+= 3}
1.1136 +
1.1137 +# Begin testing of tcltest procs ...
1.1138 +
1.1139 +cd [temporaryDirectory]
1.1140 +# PrintError
1.1141 +test tcltest-20.1 {PrintError} {unixOrPc} {
1.1142 + set result [slave msg $printerror]
1.1143 + list $result [regexp "Error: a really short string" $msg] \
1.1144 + [regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \
1.1145 + [regexp " \"Really" $msg] [regexp Problem $msg]
1.1146 +} {1 1 1 1 1 1}
1.1147 +cd [workingDirectory]
1.1148 +removeFile printerror.tcl
1.1149 +
1.1150 +# test::test
1.1151 +test tcltest-21.0 {name and desc but no args specified} -setup {
1.1152 + set v [verbose]
1.1153 +} -cleanup {
1.1154 + verbose $v
1.1155 +} -body {
1.1156 + verbose {}
1.1157 + test tcltest-21.0.0 bar
1.1158 +} -result {}
1.1159 +
1.1160 +test tcltest-21.1 {expect with glob} {
1.1161 + -body {
1.1162 + list a b c d e
1.1163 + }
1.1164 + -match glob
1.1165 + -result {[ab] b c d e}
1.1166 +}
1.1167 +
1.1168 +test tcltest-21.2 {force a test command failure} {
1.1169 + -body {
1.1170 + test tcltest-21.2.0 {
1.1171 + return 2
1.1172 + } {1}
1.1173 + }
1.1174 + -returnCodes 1
1.1175 + -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
1.1176 +}
1.1177 +
1.1178 +test tcltest-21.3 {test command with setup} {
1.1179 + -setup {
1.1180 + set foo 1
1.1181 + }
1.1182 + -body {
1.1183 + set foo
1.1184 + }
1.1185 + -cleanup {unset foo}
1.1186 + -result {1}
1.1187 +}
1.1188 +
1.1189 +test tcltest-21.4 {test command with cleanup failure} {
1.1190 + -setup {
1.1191 + if {[info exists foo]} {
1.1192 + unset foo
1.1193 + }
1.1194 + set fail $::tcltest::currentFailure
1.1195 + set v [verbose]
1.1196 + }
1.1197 + -body {
1.1198 + verbose {}
1.1199 + test tcltest-21.4.0 {foo-1} {
1.1200 + -cleanup {unset foo}
1.1201 + }
1.1202 + }
1.1203 + -result {^$}
1.1204 + -match regexp
1.1205 + -cleanup {verbose $v; set ::tcltest::currentFailure $fail}
1.1206 + -output "Test cleanup failed:.*can't unset \"foo\": no such variable"
1.1207 +}
1.1208 +
1.1209 +test tcltest-21.5 {test command with setup failure} {
1.1210 + -setup {
1.1211 + if {[info exists foo]} {
1.1212 + unset foo
1.1213 + }
1.1214 + set fail $::tcltest::currentFailure
1.1215 + }
1.1216 + -body {
1.1217 + test tcltest-21.5.0 {foo-2} {
1.1218 + -setup {unset foo}
1.1219 + }
1.1220 + }
1.1221 + -result {^$}
1.1222 + -match regexp
1.1223 + -cleanup {set ::tcltest::currentFailure $fail}
1.1224 + -output "Test setup failed:.*can't unset \"foo\": no such variable"
1.1225 +}
1.1226 +
1.1227 +test tcltest-21.6 {test command - setup occurs before cleanup & before script} {
1.1228 + -setup {set v [verbose]; set fail $::tcltest::currentFailure}
1.1229 + -body {
1.1230 + verbose {}
1.1231 + test tcltest-21.6.0 {foo-3} {
1.1232 + -setup {
1.1233 + if {[info exists foo]} {
1.1234 + unset foo
1.1235 + }
1.1236 + set foo 1
1.1237 + set expected 2
1.1238 + }
1.1239 + -body {
1.1240 + incr foo
1.1241 + set foo
1.1242 + }
1.1243 + -cleanup {
1.1244 + if {$foo != 2} {
1.1245 + puts [outputChannel] "foo is wrong"
1.1246 + } else {
1.1247 + puts [outputChannel] "foo is 2"
1.1248 + }
1.1249 + }
1.1250 + -result {$expected}
1.1251 + }
1.1252 + }
1.1253 + -cleanup {verbose $v; set ::tcltest::currentFailure $fail}
1.1254 + -result {^$}
1.1255 + -match regexp
1.1256 + -output "foo is 2"
1.1257 +}
1.1258 +
1.1259 +test tcltest-21.7 {test command - bad flag} {
1.1260 + -setup {set fail $::tcltest::currentFailure}
1.1261 + -cleanup {set ::tcltest::currentFailure $fail}
1.1262 + -body {
1.1263 + test tcltest-21.7.0 {foo-4} {
1.1264 + -foobar {}
1.1265 + }
1.1266 + }
1.1267 + -returnCodes 1
1.1268 + -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
1.1269 +}
1.1270 +
1.1271 +# alternate test command format (these are the same as 21.1-21.6, with the
1.1272 +# exception of being in the all-inline format)
1.1273 +
1.1274 +test tcltest-21.7a {expect with glob} \
1.1275 + -body {list a b c d e} \
1.1276 + -result {[ab] b c d e} \
1.1277 + -match glob
1.1278 +
1.1279 +test tcltest-21.8 {force a test command failure} \
1.1280 + -setup {set fail $::tcltest::currentFailure} \
1.1281 + -body {
1.1282 + test tcltest-21.8.0 {
1.1283 + return 2
1.1284 + } {1}
1.1285 + } \
1.1286 + -returnCodes 1 \
1.1287 + -cleanup {set ::tcltest::currentFailure $fail} \
1.1288 + -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
1.1289 +
1.1290 +test tcltest-21.9 {test command with setup} \
1.1291 + -setup {set foo 1} \
1.1292 + -body {set foo} \
1.1293 + -cleanup {unset foo} \
1.1294 + -result {1}
1.1295 +
1.1296 +test tcltest-21.10 {test command with cleanup failure} -setup {
1.1297 + if {[info exists foo]} {
1.1298 + unset foo
1.1299 + }
1.1300 + set fail $::tcltest::currentFailure
1.1301 + set v [verbose]
1.1302 +} -cleanup {
1.1303 + verbose $v
1.1304 + set ::tcltest::currentFailure $fail
1.1305 +} -body {
1.1306 + verbose {}
1.1307 + test tcltest-21.10.0 {foo-1} -cleanup {unset foo}
1.1308 +} -result {^$} -match regexp \
1.1309 + -output {Test cleanup failed:.*can't unset \"foo\": no such variable}
1.1310 +
1.1311 +test tcltest-21.11 {test command with setup failure} -setup {
1.1312 + if {[info exists foo]} {
1.1313 + unset foo
1.1314 + }
1.1315 + set fail $::tcltest::currentFailure
1.1316 +} -cleanup {set ::tcltest::currentFailure $fail} -body {
1.1317 + test tcltest-21.11.0 {foo-2} -setup {unset foo}
1.1318 +} -result {^$} -output {Test setup failed:.*can't unset \"foo\": no such variable} -match regexp
1.1319 +
1.1320 +test tcltest-21.12 {
1.1321 + test command - setup occurs before cleanup & before script
1.1322 +} -setup {
1.1323 + set fail $::tcltest::currentFailure
1.1324 + set v [verbose]
1.1325 +} -cleanup {
1.1326 + verbose $v
1.1327 + set ::tcltest::currentFailure $fail
1.1328 +} -body {
1.1329 + verbose {}
1.1330 + test tcltest-21.12.0 {foo-3} -setup {
1.1331 + if {[info exists foo]} {
1.1332 + unset foo
1.1333 + }
1.1334 + set foo 1
1.1335 + set expected 2
1.1336 + } -body {
1.1337 + incr foo
1.1338 + set foo
1.1339 + } -cleanup {
1.1340 + if {$foo != 2} {
1.1341 + puts [outputChannel] "foo is wrong"
1.1342 + } else {
1.1343 + puts [outputChannel] "foo is 2"
1.1344 + }
1.1345 + } -result {$expected}
1.1346 +} -result {^$} -output {foo is 2} -match regexp
1.1347 +
1.1348 +# test all.tcl usage (runAllTests); simulate .test file failure, as well as
1.1349 +# crashes to determine whether or not these errors are logged.
1.1350 +
1.1351 +set atd [makeDirectory alltestdir]
1.1352 +makeFile {
1.1353 + package require tcltest
1.1354 + namespace import -force tcltest::*
1.1355 + testsDirectory [file join [temporaryDirectory] alltestdir]
1.1356 + runAllTests
1.1357 +} all.tcl $atd
1.1358 +makeFile {
1.1359 + exit 1
1.1360 +} exit.test $atd
1.1361 +makeFile {
1.1362 + error "throw an error"
1.1363 +} error.test $atd
1.1364 +makeFile {
1.1365 + package require tcltest
1.1366 + namespace import -force tcltest::*
1.1367 + test foo-1.1 {foo} {
1.1368 + -body { return 1 }
1.1369 + -result {1}
1.1370 + }
1.1371 + cleanupTests
1.1372 +} test.test $atd
1.1373 +
1.1374 +# Must use a child process because stdout/stderr parsing can't be
1.1375 +# duplicated in slave interp.
1.1376 +test tcltest-22.1 {runAllTests} {
1.1377 + -constraints {unixOrPc}
1.1378 + -body {
1.1379 + exec [interpreter] \
1.1380 + [file join $atd all.tcl] \
1.1381 + -verbose t -tmpdir [temporaryDirectory]
1.1382 + }
1.1383 + -match regexp
1.1384 + -result "Test files exiting with errors:.*error.test.*exit.test"
1.1385 +}
1.1386 +removeDirectory alltestdir
1.1387 +
1.1388 +# makeFile, removeFile, makeDirectory, removeDirectory, viewFile
1.1389 +test tcltest-23.1 {makeFile} {
1.1390 + -setup {
1.1391 + set mfdir [file join [temporaryDirectory] mfdir]
1.1392 + file mkdir $mfdir
1.1393 + }
1.1394 + -body {
1.1395 + makeFile {} t1.tmp
1.1396 + makeFile {} et1.tmp $mfdir
1.1397 + list [file exists [file join [temporaryDirectory] t1.tmp]] \
1.1398 + [file exists [file join $mfdir et1.tmp]]
1.1399 + }
1.1400 + -cleanup {
1.1401 + file delete -force $mfdir \
1.1402 + [file join [temporaryDirectory] t1.tmp]
1.1403 + }
1.1404 + -result {1 1}
1.1405 +}
1.1406 +test tcltest-23.2 {removeFile} {
1.1407 + -setup {
1.1408 + set mfdir [file join [temporaryDirectory] mfdir]
1.1409 + file mkdir $mfdir
1.1410 + makeFile {} t1.tmp
1.1411 + makeFile {} et1.tmp $mfdir
1.1412 + if {![file exists [file join [temporaryDirectory] t1.tmp]] || \
1.1413 + ![file exists [file join $mfdir et1.tmp]]} {
1.1414 + error "file creation didn't work"
1.1415 + }
1.1416 + }
1.1417 + -body {
1.1418 + removeFile t1.tmp
1.1419 + removeFile et1.tmp $mfdir
1.1420 + list [file exists [file join [temporaryDirectory] t1.tmp]] \
1.1421 + [file exists [file join $mfdir et1.tmp]]
1.1422 + }
1.1423 + -cleanup {
1.1424 + file delete -force $mfdir \
1.1425 + [file join [temporaryDirectory] t1.tmp]
1.1426 + }
1.1427 + -result {0 0}
1.1428 +}
1.1429 +test tcltest-23.3 {makeDirectory} {
1.1430 + -body {
1.1431 + set mfdir [file join [temporaryDirectory] mfdir]
1.1432 + file mkdir $mfdir
1.1433 + makeDirectory d1
1.1434 + makeDirectory d2 $mfdir
1.1435 + list [file exists [file join [temporaryDirectory] d1]] \
1.1436 + [file exists [file join $mfdir d2]]
1.1437 + }
1.1438 + -cleanup {
1.1439 + file delete -force [file join [temporaryDirectory] d1] $mfdir
1.1440 + }
1.1441 + -result {1 1}
1.1442 +}
1.1443 +test tcltest-23.4 {removeDirectory} {
1.1444 + -setup {
1.1445 + set mfdir [makeDirectory mfdir]
1.1446 + makeDirectory t1
1.1447 + makeDirectory t2 $mfdir
1.1448 + if {![file exists $mfdir] || \
1.1449 + ![file exists [file join [temporaryDirectory] $mfdir t2]]} {
1.1450 + error "setup failed - directory not created"
1.1451 + }
1.1452 + }
1.1453 + -body {
1.1454 + removeDirectory t1
1.1455 + removeDirectory t2 $mfdir
1.1456 + list [file exists [file join [temporaryDirectory] t1]] \
1.1457 + [file exists [file join $mfdir t2]]
1.1458 + }
1.1459 + -result {0 0}
1.1460 +}
1.1461 +test tcltest-23.5 {viewFile} {
1.1462 + -body {
1.1463 + set mfdir [file join [temporaryDirectory] mfdir]
1.1464 + file mkdir $mfdir
1.1465 + makeFile {foobar} t1.tmp
1.1466 + makeFile {foobarbaz} t2.tmp $mfdir
1.1467 + list [viewFile t1.tmp] [viewFile t2.tmp $mfdir]
1.1468 + }
1.1469 + -result {foobar foobarbaz}
1.1470 + -cleanup {
1.1471 + file delete -force $mfdir
1.1472 + removeFile t1.tmp
1.1473 + }
1.1474 +}
1.1475 +
1.1476 +# customMatch
1.1477 +proc matchNegative { expected actual } {
1.1478 + set match 0
1.1479 + foreach a $actual e $expected {
1.1480 + if { $a != $e } {
1.1481 + set match 1
1.1482 + break
1.1483 + }
1.1484 + }
1.1485 + return $match
1.1486 +}
1.1487 +
1.1488 +test tcltest-24.0 {
1.1489 + customMatch: syntax
1.1490 +} -body {
1.1491 + list [catch {customMatch} result] $result
1.1492 +} -result [list 1 "wrong # args: should be \"customMatch mode script\""]
1.1493 +
1.1494 +test tcltest-24.1 {
1.1495 + customMatch: syntax
1.1496 +} -body {
1.1497 + list [catch {customMatch foo} result] $result
1.1498 +} -result [list 1 "wrong # args: should be \"customMatch mode script\""]
1.1499 +
1.1500 +test tcltest-24.2 {
1.1501 + customMatch: syntax
1.1502 +} -body {
1.1503 + list [catch {customMatch foo bar baz} result] $result
1.1504 +} -result [list 1 "wrong # args: should be \"customMatch mode script\""]
1.1505 +
1.1506 +test tcltest-24.3 {
1.1507 + customMatch: argument checking
1.1508 +} -body {
1.1509 + list [catch {customMatch bad "a \{ b"} result] $result
1.1510 +} -result [list 1 "invalid customMatch script; can't evaluate after completion"]
1.1511 +
1.1512 +test tcltest-24.4 {
1.1513 + test: valid -match values
1.1514 +} -body {
1.1515 + list [catch {
1.1516 + test tcltest-24.4.0 {} \
1.1517 + -match [namespace current]::noSuchMode
1.1518 + } result] $result
1.1519 +} -match glob -result {1 *bad -match value*}
1.1520 +
1.1521 +test tcltest-24.5 {
1.1522 + test: valid -match values
1.1523 +} -setup {
1.1524 + customMatch [namespace current]::alwaysMatch "format 1 ;#"
1.1525 +} -body {
1.1526 + list [catch {
1.1527 + test tcltest-24.5.0 {} \
1.1528 + -match [namespace current]::noSuchMode
1.1529 + } result] $result
1.1530 +} -match glob -result {1 *bad -match value*: must be *alwaysMatch,*}
1.1531 +
1.1532 +test tcltest-24.6 {
1.1533 + customMatch: -match script that always matches
1.1534 +} -setup {
1.1535 + customMatch [namespace current]::alwaysMatch "format 1 ;#"
1.1536 + set v [verbose]
1.1537 +} -body {
1.1538 + verbose {}
1.1539 + test tcltest-24.6.0 {} -match [namespace current]::alwaysMatch \
1.1540 + -body {format 1} -result 0
1.1541 +} -cleanup {
1.1542 + verbose $v
1.1543 +} -result {} -output {} -errorOutput {}
1.1544 +
1.1545 +test tcltest-24.7 {
1.1546 + customMatch: replace default -exact matching
1.1547 +} -setup {
1.1548 + set saveExactMatchScript $::tcltest::CustomMatch(exact)
1.1549 + customMatch exact "format 1 ;#"
1.1550 + set v [verbose]
1.1551 +} -body {
1.1552 + verbose {}
1.1553 + test tcltest-24.7.0 {} -body {format 1} -result 0
1.1554 +} -cleanup {
1.1555 + verbose $v
1.1556 + customMatch exact $saveExactMatchScript
1.1557 + unset saveExactMatchScript
1.1558 +} -result {} -output {}
1.1559 +
1.1560 +test tcltest-24.9 {
1.1561 + customMatch: error during match
1.1562 +} -setup {
1.1563 + proc errorDuringMatch args {return -code error "match returned error"}
1.1564 + customMatch [namespace current]::errorDuringMatch \
1.1565 + [namespace code errorDuringMatch]
1.1566 + set v [verbose]
1.1567 + set fail $::tcltest::currentFailure
1.1568 +} -body {
1.1569 + verbose {}
1.1570 + test tcltest-24.9.0 {} -match [namespace current]::errorDuringMatch
1.1571 +} -cleanup {
1.1572 + verbose $v
1.1573 + set ::tcltest::currentFailure $fail
1.1574 +} -match glob -result {} -output {*FAILED*match returned error*}
1.1575 +
1.1576 +test tcltest-24.10 {
1.1577 + customMatch: bad return from match command
1.1578 +} -setup {
1.1579 + proc nonBooleanReturn args {return foo}
1.1580 + customMatch nonBooleanReturn [namespace code nonBooleanReturn]
1.1581 + set v [verbose]
1.1582 + set fail $::tcltest::currentFailure
1.1583 +} -body {
1.1584 + verbose {}
1.1585 + test tcltest-24.10.0 {} -match nonBooleanReturn
1.1586 +} -cleanup {
1.1587 + verbose $v
1.1588 + set ::tcltest::currentFailure $fail
1.1589 +} -match glob -result {} -output {*FAILED*expected boolean value*}
1.1590 +
1.1591 +test tcltest-24.11 {
1.1592 + test: -match exact
1.1593 +} -body {
1.1594 + set result {A B C}
1.1595 +} -match exact -result {A B C}
1.1596 +
1.1597 +test tcltest-24.12 {
1.1598 + test: -match exact match command eval in ::, not caller namespace
1.1599 +} -setup {
1.1600 + set saveExactMatchScript $::tcltest::CustomMatch(exact)
1.1601 + customMatch exact [list string equal]
1.1602 + set v [verbose]
1.1603 + proc string args {error {called [string] in caller namespace}}
1.1604 +} -body {
1.1605 + verbose {}
1.1606 + test tcltest-24.12.0 {} -body {format 1} -result 1
1.1607 +} -cleanup {
1.1608 + rename string {}
1.1609 + verbose $v
1.1610 + customMatch exact $saveExactMatchScript
1.1611 + unset saveExactMatchScript
1.1612 +} -match exact -result {} -output {}
1.1613 +
1.1614 +test tcltest-24.13 {
1.1615 + test: -match exact failure
1.1616 +} -setup {
1.1617 + set saveExactMatchScript $::tcltest::CustomMatch(exact)
1.1618 + customMatch exact [list string equal]
1.1619 + set v [verbose]
1.1620 + set fail $::tcltest::currentFailure
1.1621 +} -body {
1.1622 + verbose {}
1.1623 + test tcltest-24.13.0 {} -body {format 1} -result 0
1.1624 +} -cleanup {
1.1625 + set ::tcltest::currentFailure $fail
1.1626 + verbose $v
1.1627 + customMatch exact $saveExactMatchScript
1.1628 + unset saveExactMatchScript
1.1629 +} -match glob -result {} -output {*FAILED*Result was:
1.1630 +1*(exact matching):
1.1631 +0*}
1.1632 +
1.1633 +test tcltest-24.14 {
1.1634 + test: -match glob
1.1635 +} -body {
1.1636 + set result {A B C}
1.1637 +} -match glob -result {A B*}
1.1638 +
1.1639 +test tcltest-24.15 {
1.1640 + test: -match glob failure
1.1641 +} -setup {
1.1642 + set v [verbose]
1.1643 + set fail $::tcltest::currentFailure
1.1644 +} -body {
1.1645 + verbose {}
1.1646 + test tcltest-24.15.0 {} -match glob -body {format {A B C}} \
1.1647 + -result {A B* }
1.1648 +} -cleanup {
1.1649 + set ::tcltest::currentFailure $fail
1.1650 + verbose $v
1.1651 +} -match glob -result {} -output {*FAILED*Result was:
1.1652 +*(glob matching):
1.1653 +*}
1.1654 +
1.1655 +test tcltest-24.16 {
1.1656 + test: -match regexp
1.1657 +} -body {
1.1658 + set result {A B C}
1.1659 +} -match regexp -result {A B.*}
1.1660 +
1.1661 +test tcltest-24.17 {
1.1662 + test: -match regexp failure
1.1663 +} -setup {
1.1664 + set fail $::tcltest::currentFailure
1.1665 + set v [verbose]
1.1666 +} -body {
1.1667 + verbose {}
1.1668 + test tcltest-24.17.0 {} -match regexp -body {format {A B C}} \
1.1669 + -result {A B.* X}
1.1670 +} -cleanup {
1.1671 + set ::tcltest::currentFailure $fail
1.1672 + verbose $v
1.1673 +} -match glob -result {} -output {*FAILED*Result was:
1.1674 +*(regexp matching):
1.1675 +*}
1.1676 +
1.1677 +test tcltest-24.18 {
1.1678 + test: -match custom forget namespace qualification
1.1679 +} -setup {
1.1680 + set fail $::tcltest::currentFailure
1.1681 + set v [verbose]
1.1682 + customMatch negative matchNegative
1.1683 +} -body {
1.1684 + verbose {}
1.1685 + test tcltest-24.18.0 {} -match negative -body {format {A B C}} \
1.1686 + -result {A B X}
1.1687 +} -cleanup {
1.1688 + set ::tcltest::currentFailure $fail
1.1689 + verbose $v
1.1690 +} -match glob -result {} -output {*FAILED*Error testing result:*}
1.1691 +
1.1692 +test tcltest-24.19 {
1.1693 + test: -match custom
1.1694 +} -setup {
1.1695 + set v [verbose]
1.1696 + customMatch negative [namespace code matchNegative]
1.1697 +} -body {
1.1698 + verbose {}
1.1699 + test tcltest-24.19.0 {} -match negative -body {format {A B C}} \
1.1700 + -result {A B X}
1.1701 +} -cleanup {
1.1702 + verbose $v
1.1703 +} -match exact -result {} -output {}
1.1704 +
1.1705 +test tcltest-24.20 {
1.1706 + test: -match custom failure
1.1707 +} -setup {
1.1708 + set fail $::tcltest::currentFailure
1.1709 + set v [verbose]
1.1710 + customMatch negative [namespace code matchNegative]
1.1711 +} -body {
1.1712 + verbose {}
1.1713 + test tcltest-24.20.0 {} -match negative -body {format {A B C}} \
1.1714 + -result {A B C}
1.1715 +} -cleanup {
1.1716 + set ::tcltest::currentFailure $fail
1.1717 + verbose $v
1.1718 +} -match glob -result {} -output {*FAILED*Result was:
1.1719 +*(negative matching):
1.1720 +*}
1.1721 +
1.1722 +test tcltest-25.1 {
1.1723 + constraint of setup/cleanup (Bug 589859)
1.1724 +} -setup {
1.1725 + set foo 0
1.1726 +} -body {
1.1727 + # Buggy tcltest will generate result of 2
1.1728 + test tcltest-25.1.0 {} -constraints knownBug -setup {
1.1729 + incr foo
1.1730 + } -body {
1.1731 + incr foo
1.1732 + } -cleanup {
1.1733 + incr foo
1.1734 + } -match glob -result *
1.1735 + set foo
1.1736 +} -cleanup {
1.1737 + unset foo
1.1738 +} -result 0
1.1739 +
1.1740 +test tcltest-25.2 {
1.1741 + puts -nonewline (Bug 612786)
1.1742 +} -body {
1.1743 + puts -nonewline stdout bla
1.1744 + puts -nonewline stdout bla
1.1745 +} -output {blabla}
1.1746 +
1.1747 +test tcltest-25.3 {
1.1748 + reported return code (Bug 611922)
1.1749 +} -setup {
1.1750 + set fail $::tcltest::currentFailure
1.1751 + set v [verbose]
1.1752 +} -body {
1.1753 + verbose {}
1.1754 + test tcltest-25.3.0 {} -body {
1.1755 + error foo
1.1756 + }
1.1757 +} -cleanup {
1.1758 + set ::tcltest::currentFailure $fail
1.1759 + verbose $v
1.1760 +} -match glob -output {*generated error; Return code was: 1*}
1.1761 +
1.1762 +test tcltest-26.1 {Bug/RFE 1017151} -setup {
1.1763 + makeFile {
1.1764 + package require tcltest
1.1765 + set errorInfo "Should never see this"
1.1766 + tcltest::test tcltest-26.1.0 {
1.1767 + no errorInfo when only return code mismatch
1.1768 + } -body {
1.1769 + set x 1
1.1770 + } -returnCodes error -result 1
1.1771 + tcltest::cleanupTests
1.1772 + } test.tcl
1.1773 +} -body {
1.1774 + slave msg [file join [temporaryDirectory] test.tcl]
1.1775 + set msg
1.1776 +} -cleanup {
1.1777 + removeFile test.tcl
1.1778 +} -match glob -result {*
1.1779 +---- Return code should have been one of: 1
1.1780 +==== tcltest-26.1.0 FAILED*}
1.1781 +
1.1782 +test tcltest-26.2 {Bug/RFE 1017151} -setup {
1.1783 + makeFile {
1.1784 + package require tcltest
1.1785 + set errorInfo "Should never see this"
1.1786 + tcltest::test tcltest-26.2.0 {do not mask body errorInfo} -body {
1.1787 + error "body error"
1.1788 + } -cleanup {
1.1789 + error "cleanup error"
1.1790 + } -result 1
1.1791 + tcltest::cleanupTests
1.1792 + } test.tcl
1.1793 +} -body {
1.1794 + slave msg [file join [temporaryDirectory] test.tcl]
1.1795 + set msg
1.1796 +} -cleanup {
1.1797 + removeFile test.tcl
1.1798 +} -match glob -result {*
1.1799 +---- errorInfo: body error
1.1800 +*
1.1801 +---- errorInfo(cleanup): cleanup error*}
1.1802 +
1.1803 +cleanupTests
1.1804 +}
1.1805 +
1.1806 +namespace delete ::tcltest::test
1.1807 +return