[25] | 1 | # This file contains a collection of tests for one or more of the Tcl |
---|
| 2 | # built-in commands. Sourcing this file into Tcl runs the tests and |
---|
| 3 | # generates output for errors. No output means no errors were found. |
---|
| 4 | # |
---|
| 5 | # Copyright (c) 1998-1999 by Scriptics Corporation. |
---|
| 6 | # Copyright (c) 2000 by Ajuba Solutions |
---|
| 7 | # All rights reserved. |
---|
| 8 | # |
---|
| 9 | # RCS: @(#) $Id: tcltest.test,v 1.55 2007/01/18 22:09:44 dkf Exp $ |
---|
| 10 | |
---|
| 11 | # Note that there are several places where the value of |
---|
| 12 | # tcltest::currentFailure is stored/reset in the -setup/-cleanup |
---|
| 13 | # of a test that has a body that runs [test] that will fail. |
---|
| 14 | # This is a workaround of using the same tcltest code that we are |
---|
| 15 | # testing to run the test itself. Ditto on things like [verbose]. |
---|
| 16 | # |
---|
| 17 | # It would be better to have the -body of the tests run the tcltest |
---|
| 18 | # commands in a slave interp so the [test] being tested would not |
---|
| 19 | # interfere with the [test] doing the testing. |
---|
| 20 | # |
---|
| 21 | |
---|
| 22 | if {[catch {package require tcltest 2.1}]} { |
---|
| 23 | puts stderr "Skipping tests in [info script]. tcltest 2.1 required." |
---|
| 24 | return |
---|
| 25 | } |
---|
| 26 | |
---|
| 27 | namespace eval ::tcltest::test { |
---|
| 28 | |
---|
| 29 | namespace import ::tcltest::* |
---|
| 30 | |
---|
| 31 | makeFile { |
---|
| 32 | package require tcltest |
---|
| 33 | namespace import ::tcltest::test |
---|
| 34 | test a-1.0 {test a} { |
---|
| 35 | list 0 |
---|
| 36 | } {0} |
---|
| 37 | test b-1.0 {test b} { |
---|
| 38 | list 1 |
---|
| 39 | } {0} |
---|
| 40 | test c-1.0 {test c} {knownBug} { |
---|
| 41 | } {} |
---|
| 42 | test d-1.0 {test d} { |
---|
| 43 | error "foo" foo 9 |
---|
| 44 | } {} |
---|
| 45 | tcltest::cleanupTests |
---|
| 46 | exit |
---|
| 47 | } test.tcl |
---|
| 48 | |
---|
| 49 | cd [temporaryDirectory] |
---|
| 50 | testConstraint exec [llength [info commands exec]] |
---|
| 51 | # test -help |
---|
| 52 | # Child processes because -help [exit]s. |
---|
| 53 | test tcltest-1.1 {tcltest -help} {exec} { |
---|
| 54 | set result [catch {exec [interpreter] test.tcl -help} msg] |
---|
| 55 | list $result [regexp Usage $msg] |
---|
| 56 | } {1 1} |
---|
| 57 | test tcltest-1.2 {tcltest -help -something} {exec} { |
---|
| 58 | set result [catch {exec [interpreter] test.tcl -help -something} msg] |
---|
| 59 | list $result [regexp Usage $msg] |
---|
| 60 | } {1 1} |
---|
| 61 | test tcltest-1.3 {tcltest -h} {exec} { |
---|
| 62 | set result [catch {exec [interpreter] test.tcl -h} msg] |
---|
| 63 | list $result [regexp Usage $msg] |
---|
| 64 | } {1 0} |
---|
| 65 | |
---|
| 66 | # -verbose, implicit & explicit testing of [verbose] |
---|
| 67 | proc slave {msgVar args} { |
---|
| 68 | upvar 1 $msgVar msg |
---|
| 69 | |
---|
| 70 | interp create [namespace current]::i |
---|
| 71 | # Fake the slave interp into dumping output to a file |
---|
| 72 | i eval {namespace eval ::tcltest {}} |
---|
| 73 | i eval "set tcltest::outputChannel\ |
---|
| 74 | \[[list open [set of [makeFile {} output]] w]]" |
---|
| 75 | i eval "set tcltest::errorChannel\ |
---|
| 76 | \[[list open [set ef [makeFile {} error]] w]]" |
---|
| 77 | i eval [list set argv0 [lindex $args 0]] |
---|
| 78 | i eval [list set argv [lrange $args 1 end]] |
---|
| 79 | i eval [list package ifneeded tcltest [package provide tcltest] \ |
---|
| 80 | [package ifneeded tcltest [package provide tcltest]]] |
---|
| 81 | i eval {proc exit args {}} |
---|
| 82 | |
---|
| 83 | # Need to capture output in msg |
---|
| 84 | |
---|
| 85 | set code [catch {i eval {source $argv0}} foo] |
---|
| 86 | if $code { |
---|
| 87 | #puts "$code: $foo\n$::errorInfo" |
---|
| 88 | } |
---|
| 89 | i eval {close $tcltest::outputChannel} |
---|
| 90 | interp delete [namespace current]::i |
---|
| 91 | set f [open $of] |
---|
| 92 | set msg [read -nonewline $f] |
---|
| 93 | close $f |
---|
| 94 | set f [open $ef] |
---|
| 95 | set err [read -nonewline $f] |
---|
| 96 | close $f |
---|
| 97 | removeFile output |
---|
| 98 | removeFile error |
---|
| 99 | if {[string length $err]} { |
---|
| 100 | set code 1 |
---|
| 101 | append msg \n$err |
---|
| 102 | } |
---|
| 103 | return $code |
---|
| 104 | |
---|
| 105 | # return [catch {uplevel 1 [linsert $args 0 exec [interpreter]]} msg] |
---|
| 106 | } |
---|
| 107 | test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} { |
---|
| 108 | set result [slave msg test.tcl] |
---|
| 109 | list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ |
---|
| 110 | [regexp c-1.0 $msg] \ |
---|
| 111 | [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] |
---|
| 112 | } {0 1 0 0 1} |
---|
| 113 | test tcltest-2.1 {tcltest -verbose 'b'} {unixOrPc} { |
---|
| 114 | set result [slave msg test.tcl -verbose 'b'] |
---|
| 115 | list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ |
---|
| 116 | [regexp c-1.0 $msg] \ |
---|
| 117 | [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] |
---|
| 118 | } {0 1 0 0 1} |
---|
| 119 | test tcltest-2.2 {tcltest -verbose 'p'} {unixOrPc} { |
---|
| 120 | set result [slave msg test.tcl -verbose 'p'] |
---|
| 121 | list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ |
---|
| 122 | [regexp c-1.0 $msg] \ |
---|
| 123 | [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] |
---|
| 124 | } {0 0 1 0 1} |
---|
| 125 | test tcltest-2.3 {tcltest -verbose 's'} {unixOrPc} { |
---|
| 126 | set result [slave msg test.tcl -verbose 's'] |
---|
| 127 | list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ |
---|
| 128 | [regexp c-1.0 $msg] \ |
---|
| 129 | [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] |
---|
| 130 | } {0 0 0 1 1} |
---|
| 131 | test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrPc} { |
---|
| 132 | set result [slave msg test.tcl -verbose 'ps'] |
---|
| 133 | list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ |
---|
| 134 | [regexp c-1.0 $msg] \ |
---|
| 135 | [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] |
---|
| 136 | } {0 0 1 1 1} |
---|
| 137 | test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrPc} { |
---|
| 138 | set result [slave msg test.tcl -verbose 'psb'] |
---|
| 139 | list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ |
---|
| 140 | [regexp c-1.0 $msg] \ |
---|
| 141 | [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] |
---|
| 142 | } {0 1 1 1 1} |
---|
| 143 | |
---|
| 144 | test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} { |
---|
| 145 | set result [slave msg test.tcl -verbose "pass skip body"] |
---|
| 146 | list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ |
---|
| 147 | [regexp c-1.0 $msg] \ |
---|
| 148 | [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] |
---|
| 149 | } {0 1 1 1 1} |
---|
| 150 | |
---|
| 151 | test tcltest-2.6 {tcltest -verbose 't'} { |
---|
| 152 | -constraints {unixOrPc} |
---|
| 153 | -body { |
---|
| 154 | set result [slave msg test.tcl -verbose 't'] |
---|
| 155 | list $result $msg |
---|
| 156 | } |
---|
| 157 | -result {^0 .*a-1.0 start.*b-1.0 start} |
---|
| 158 | -match regexp |
---|
| 159 | } |
---|
| 160 | |
---|
| 161 | test tcltest-2.6a {tcltest -verbose 'start'} { |
---|
| 162 | -constraints {unixOrPc} |
---|
| 163 | -body { |
---|
| 164 | set result [slave msg test.tcl -verbose start] |
---|
| 165 | list $result $msg |
---|
| 166 | } |
---|
| 167 | -result {^0 .*a-1.0 start.*b-1.0 start} |
---|
| 168 | -match regexp |
---|
| 169 | } |
---|
| 170 | |
---|
| 171 | test tcltest-2.7 {tcltest::verbose} { |
---|
| 172 | -body { |
---|
| 173 | set oldVerbosity [verbose] |
---|
| 174 | verbose bar |
---|
| 175 | set currentVerbosity [verbose] |
---|
| 176 | verbose foo |
---|
| 177 | set newVerbosity [verbose] |
---|
| 178 | verbose $oldVerbosity |
---|
| 179 | list $currentVerbosity $newVerbosity |
---|
| 180 | } |
---|
| 181 | -result {body {}} |
---|
| 182 | } |
---|
| 183 | |
---|
| 184 | test tcltest-2.8 {tcltest -verbose 'error'} { |
---|
| 185 | -constraints {unixOrPc} |
---|
| 186 | -body { |
---|
| 187 | set result [slave msg test.tcl -verbose error] |
---|
| 188 | list $result $msg |
---|
| 189 | } |
---|
| 190 | -result {errorInfo: foo.*errorCode: 9} |
---|
| 191 | -match regexp |
---|
| 192 | } |
---|
| 193 | # -match, [match] |
---|
| 194 | test tcltest-3.1 {tcltest -match 'a*'} {unixOrPc} { |
---|
| 195 | set result [slave msg test.tcl -match a* -verbose 'ps'] |
---|
| 196 | list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ |
---|
| 197 | [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] |
---|
| 198 | } {0 1 0 0 1} |
---|
| 199 | test tcltest-3.2 {tcltest -match 'b*'} {unixOrPc} { |
---|
| 200 | set result [slave msg test.tcl -match b* -verbose 'ps'] |
---|
| 201 | list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ |
---|
| 202 | [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg] |
---|
| 203 | } {0 0 1 0 1} |
---|
| 204 | test tcltest-3.3 {tcltest -match 'c*'} {unixOrPc} { |
---|
| 205 | set result [slave msg test.tcl -match c* -verbose 'ps'] |
---|
| 206 | list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ |
---|
| 207 | [regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg] |
---|
| 208 | } {0 0 0 1 1} |
---|
| 209 | test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrPc} { |
---|
| 210 | set result [slave msg test.tcl -match {a* b*} -verbose 'ps'] |
---|
| 211 | list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ |
---|
| 212 | [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg] |
---|
| 213 | } {0 1 1 0 1} |
---|
| 214 | |
---|
| 215 | test tcltest-3.5 {tcltest::match} { |
---|
| 216 | -body { |
---|
| 217 | set oldMatch [match] |
---|
| 218 | match foo |
---|
| 219 | set currentMatch [match] |
---|
| 220 | match bar |
---|
| 221 | set newMatch [match] |
---|
| 222 | match $oldMatch |
---|
| 223 | list $currentMatch $newMatch |
---|
| 224 | } |
---|
| 225 | -result {foo bar} |
---|
| 226 | } |
---|
| 227 | |
---|
| 228 | # -skip, [skip] |
---|
| 229 | test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} { |
---|
| 230 | set result [slave msg test.tcl -skip a* -verbose 'ps'] |
---|
| 231 | list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ |
---|
| 232 | [regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg] |
---|
| 233 | } {0 0 1 1 1} |
---|
| 234 | test tcltest-4.2 {tcltest -skip 'b*'} {unixOrPc} { |
---|
| 235 | set result [slave msg test.tcl -skip b* -verbose 'ps'] |
---|
| 236 | list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ |
---|
| 237 | [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg] |
---|
| 238 | } {0 1 0 1 1} |
---|
| 239 | test tcltest-4.3 {tcltest -skip 'c*'} {unixOrPc} { |
---|
| 240 | set result [slave msg test.tcl -skip c* -verbose 'ps'] |
---|
| 241 | list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ |
---|
| 242 | [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] |
---|
| 243 | } {0 1 1 0 1} |
---|
| 244 | test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrPc} { |
---|
| 245 | set result [slave msg test.tcl -skip {a* b*} -verbose 'ps'] |
---|
| 246 | list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ |
---|
| 247 | [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg] |
---|
| 248 | } {0 0 0 1 1} |
---|
| 249 | test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrPc} { |
---|
| 250 | set result [slave msg test.tcl -match {a* b*} -skip b* -verbose 'ps'] |
---|
| 251 | list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ |
---|
| 252 | [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] |
---|
| 253 | } {0 1 0 0 1} |
---|
| 254 | |
---|
| 255 | test tcltest-4.6 {tcltest::skip} { |
---|
| 256 | -body { |
---|
| 257 | set oldSkip [skip] |
---|
| 258 | skip foo |
---|
| 259 | set currentSkip [skip] |
---|
| 260 | skip bar |
---|
| 261 | set newSkip [skip] |
---|
| 262 | skip $oldSkip |
---|
| 263 | list $currentSkip $newSkip |
---|
| 264 | } |
---|
| 265 | -result {foo bar} |
---|
| 266 | } |
---|
| 267 | |
---|
| 268 | # -constraints, -limitconstraints, [testConstraint], |
---|
| 269 | # $constraintsSpecified, [limitConstraints] |
---|
| 270 | test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} { |
---|
| 271 | set result [slave msg test.tcl -constraints knownBug -verbose 'ps'] |
---|
| 272 | list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ |
---|
| 273 | [regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg] |
---|
| 274 | } {0 1 1 1 1} |
---|
| 275 | test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrPc} { |
---|
| 276 | set result [slave msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1] |
---|
| 277 | list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ |
---|
| 278 | [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] |
---|
| 279 | } {0 0 0 1 1} |
---|
| 280 | |
---|
| 281 | test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)} { |
---|
| 282 | -body { |
---|
| 283 | set r1 [testConstraint tcltestFakeConstraint] |
---|
| 284 | set r2 [testConstraint tcltestFakeConstraint 4] |
---|
| 285 | set r3 [testConstraint tcltestFakeConstraint] |
---|
| 286 | list $r1 $r2 $r3 |
---|
| 287 | } |
---|
| 288 | -result {0 4 4} |
---|
| 289 | -cleanup {unset ::tcltest::testConstraints(tcltestFakeConstraint)} |
---|
| 290 | } |
---|
| 291 | |
---|
| 292 | # Removed this test of internals of tcltest. Those internals have changed. |
---|
| 293 | #test tcltest-5.4 {tcltest::constraintsSpecified} { |
---|
| 294 | # -setup { |
---|
| 295 | # set constraintlist $::tcltest::constraintsSpecified |
---|
| 296 | # set ::tcltest::constraintsSpecified {} |
---|
| 297 | # } |
---|
| 298 | # -body { |
---|
| 299 | # set r1 $::tcltest::constraintsSpecified |
---|
| 300 | # testConstraint tcltestFakeConstraint1 1 |
---|
| 301 | # set r2 $::tcltest::constraintsSpecified |
---|
| 302 | # testConstraint tcltestFakeConstraint2 1 |
---|
| 303 | # set r3 $::tcltest::constraintsSpecified |
---|
| 304 | # list $r1 $r2 $r3 |
---|
| 305 | # } |
---|
| 306 | # -result {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}} |
---|
| 307 | # -cleanup { |
---|
| 308 | # set ::tcltest::constraintsSpecified $constraintlist |
---|
| 309 | # unset ::tcltest::testConstraints(tcltestFakeConstraint1) |
---|
| 310 | # unset ::tcltest::testConstraints(tcltestFakeConstraint2) |
---|
| 311 | # } |
---|
| 312 | #} |
---|
| 313 | |
---|
| 314 | test tcltest-5.5 {InitConstraints: list of built-in constraints} \ |
---|
| 315 | -constraints {!singleTestInterp} \ |
---|
| 316 | -setup {tcltest::InitConstraints} \ |
---|
| 317 | -body { lsort [array names ::tcltest::testConstraints] } \ |
---|
| 318 | -result [lsort { |
---|
| 319 | 95 98 asyncPipeClose eformat emptyTest exec hasIsoLocale interactive |
---|
| 320 | knownBug mac macCrash macOnly macOrPc macOrUnix macOrWin nonBlockFiles |
---|
| 321 | nonPortable notRoot nt pc pcCrash pcOnly root singleTestInterp socket |
---|
| 322 | stdio tempNotMac tempNotPc tempNotUnix tempNotWin unix unixCrash unixExecs |
---|
| 323 | unixOnly unixOrPc unixOrWin userInteraction win winCrash winOnly |
---|
| 324 | }] |
---|
| 325 | |
---|
| 326 | # Removed this broken test. Its usage of [limitConstraints] was not |
---|
| 327 | # in agreement with the documentation. [limitConstraints] is supposed |
---|
| 328 | # to take an optional boolean argument, and "knownBug" ain't no boolean! |
---|
| 329 | #test tcltest-5.6 {tcltest::limitConstraints} { |
---|
| 330 | # -setup { |
---|
| 331 | # set keeplc $::tcltest::limitConstraints |
---|
| 332 | # set keepkb [testConstraint knownBug] |
---|
| 333 | # } |
---|
| 334 | # -body { |
---|
| 335 | # set r1 [limitConstraints] |
---|
| 336 | # set r2 [limitConstraints knownBug] |
---|
| 337 | # set r3 [limitConstraints] |
---|
| 338 | # list $r1 $r2 $r3 |
---|
| 339 | # } |
---|
| 340 | # -cleanup { |
---|
| 341 | # limitConstraints $keeplc |
---|
| 342 | # testConstraint knownBug $keepkb |
---|
| 343 | # } |
---|
| 344 | # -result {false knownBug knownBug} |
---|
| 345 | #} |
---|
| 346 | |
---|
| 347 | # -outfile, -errfile, [outputChannel], [outputFile], [errorChannel], [errorFile] |
---|
| 348 | set printerror [makeFile { |
---|
| 349 | package require tcltest |
---|
| 350 | namespace import ::tcltest::* |
---|
| 351 | puts [outputChannel] "a test" |
---|
| 352 | ::tcltest::PrintError "a really short string" |
---|
| 353 | ::tcltest::PrintError "a really really really really really really long \ |
---|
| 354 | string containing \"quotes\" and other bad bad stuff" |
---|
| 355 | ::tcltest::PrintError "a really really long string containing a \ |
---|
| 356 | \"Path/that/is/really/long/and/contains/no/spaces\"" |
---|
| 357 | ::tcltest::PrintError "a really really long string containing a \ |
---|
| 358 | \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\"" |
---|
| 359 | ::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\"" |
---|
| 360 | exit |
---|
| 361 | } printerror.tcl] |
---|
| 362 | |
---|
| 363 | test tcltest-6.1 {tcltest -outfile, -errfile defaults} { |
---|
| 364 | -constraints unixOrPc |
---|
| 365 | -body { |
---|
| 366 | slave msg $printerror |
---|
| 367 | return $msg |
---|
| 368 | } |
---|
| 369 | -result {a test.*a really} |
---|
| 370 | -match regexp |
---|
| 371 | } |
---|
| 372 | test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} { |
---|
| 373 | slave msg $printerror -outfile a.tmp |
---|
| 374 | set result1 [catch {exec grep "a test" a.tmp}] |
---|
| 375 | set result2 [catch {exec grep "a really" a.tmp}] |
---|
| 376 | list [regexp "a test" $msg] [regexp "a really" $msg] \ |
---|
| 377 | $result1 $result2 [file exists a.tmp] [file delete a.tmp] |
---|
| 378 | } {0 1 0 1 1 {}} |
---|
| 379 | test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} { |
---|
| 380 | slave msg $printerror -errfile a.tmp |
---|
| 381 | set result1 [catch {exec grep "a test" a.tmp}] |
---|
| 382 | set result2 [catch {exec grep "a really" a.tmp}] |
---|
| 383 | list [regexp "a test" $msg] [regexp "a really" $msg] \ |
---|
| 384 | $result1 $result2 [file exists a.tmp] [file delete a.tmp] |
---|
| 385 | } {1 0 1 0 1 {}} |
---|
| 386 | test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrPc unixExecs} { |
---|
| 387 | slave msg $printerror -outfile a.tmp -errfile b.tmp |
---|
| 388 | set result1 [catch {exec grep "a test" a.tmp}] |
---|
| 389 | set result2 [catch {exec grep "a really" b.tmp}] |
---|
| 390 | list [regexp "a test" $msg] [regexp "a really" $msg] \ |
---|
| 391 | $result1 $result2 \ |
---|
| 392 | [file exists a.tmp] [file delete a.tmp] \ |
---|
| 393 | [file exists b.tmp] [file delete b.tmp] |
---|
| 394 | } {0 0 0 0 1 {} 1 {}} |
---|
| 395 | |
---|
| 396 | test tcltest-6.5 {tcltest::errorChannel - retrieval} { |
---|
| 397 | -setup { |
---|
| 398 | set of [errorChannel] |
---|
| 399 | set ::tcltest::errorChannel stderr |
---|
| 400 | } |
---|
| 401 | -body { |
---|
| 402 | errorChannel |
---|
| 403 | } |
---|
| 404 | -result {stderr} |
---|
| 405 | -cleanup { |
---|
| 406 | set ::tcltest::errorChannel $of |
---|
| 407 | } |
---|
| 408 | } |
---|
| 409 | |
---|
| 410 | test tcltest-6.6 {tcltest::errorFile (implicit errorChannel)} { |
---|
| 411 | -setup { |
---|
| 412 | set ef [makeFile {} efile] |
---|
| 413 | set of [errorFile] |
---|
| 414 | set ::tcltest::errorChannel stderr |
---|
| 415 | set ::tcltest::errorFile stderr |
---|
| 416 | } |
---|
| 417 | -body { |
---|
| 418 | set f0 [errorChannel] |
---|
| 419 | set f1 [errorFile] |
---|
| 420 | set f2 [errorFile $ef] |
---|
| 421 | set f3 [errorChannel] |
---|
| 422 | set f4 [errorFile] |
---|
| 423 | subst {$f0;$f1;$f2;$f3;$f4} |
---|
| 424 | } |
---|
| 425 | -result {stderr;stderr;.*efile;file[0-9a-f]+;.*efile} |
---|
| 426 | -match regexp |
---|
| 427 | -cleanup { |
---|
| 428 | errorFile $of |
---|
| 429 | removeFile efile |
---|
| 430 | } |
---|
| 431 | } |
---|
| 432 | test tcltest-6.7 {tcltest::outputChannel - retrieval} { |
---|
| 433 | -setup { |
---|
| 434 | set of [outputChannel] |
---|
| 435 | set ::tcltest::outputChannel stdout |
---|
| 436 | } |
---|
| 437 | -body { |
---|
| 438 | outputChannel |
---|
| 439 | } |
---|
| 440 | -result {stdout} |
---|
| 441 | -cleanup { |
---|
| 442 | set ::tcltest::outputChannel $of |
---|
| 443 | } |
---|
| 444 | } |
---|
| 445 | |
---|
| 446 | test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} { |
---|
| 447 | -setup { |
---|
| 448 | set ef [makeFile {} efile] |
---|
| 449 | set of [outputFile] |
---|
| 450 | set ::tcltest::outputChannel stdout |
---|
| 451 | set ::tcltest::outputFile stdout |
---|
| 452 | } |
---|
| 453 | -body { |
---|
| 454 | set f0 [outputChannel] |
---|
| 455 | set f1 [outputFile] |
---|
| 456 | set f2 [outputFile $ef] |
---|
| 457 | set f3 [outputChannel] |
---|
| 458 | set f4 [outputFile] |
---|
| 459 | subst {$f0;$f1;$f2;$f3;$f4} |
---|
| 460 | } |
---|
| 461 | -result {stdout;stdout;.*efile;file[0-9a-f]+;.*efile} |
---|
| 462 | -match regexp |
---|
| 463 | -cleanup { |
---|
| 464 | outputFile $of |
---|
| 465 | removeFile efile |
---|
| 466 | } |
---|
| 467 | } |
---|
| 468 | |
---|
| 469 | # -debug, [debug] |
---|
| 470 | # Must use child processes to test -debug because it always writes |
---|
| 471 | # messages to stdout, and we have no way to capture stdout of a |
---|
| 472 | # slave interp |
---|
| 473 | test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrPc} { |
---|
| 474 | catch {exec [interpreter] test.tcl -debug 0} msg |
---|
| 475 | regexp "Flags passed into tcltest" $msg |
---|
| 476 | } {0} |
---|
| 477 | test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrPc} { |
---|
| 478 | catch {exec [interpreter] test.tcl -debug 1 -skip b*} msg |
---|
| 479 | list [regexp userSpecifiedSkip $msg] \ |
---|
| 480 | [regexp "Flags passed into tcltest" $msg] |
---|
| 481 | } {1 0} |
---|
| 482 | test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrPc} { |
---|
| 483 | catch {exec [interpreter] test.tcl -debug 1 -match b*} msg |
---|
| 484 | list [regexp userSpecifiedNonMatch $msg] \ |
---|
| 485 | [regexp "Flags passed into tcltest" $msg] |
---|
| 486 | } {1 0} |
---|
| 487 | test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrPc} { |
---|
| 488 | catch {exec [interpreter] test.tcl -debug 2} msg |
---|
| 489 | list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg] |
---|
| 490 | } {1 0} |
---|
| 491 | test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrPc} { |
---|
| 492 | catch {exec [interpreter] test.tcl -debug 3} msg |
---|
| 493 | list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg] |
---|
| 494 | } {1 1} |
---|
| 495 | |
---|
| 496 | test tcltest-7.6 {tcltest::debug} { |
---|
| 497 | -setup { |
---|
| 498 | set old $::tcltest::debug |
---|
| 499 | set ::tcltest::debug 0 |
---|
| 500 | } |
---|
| 501 | -body { |
---|
| 502 | set f1 [debug] |
---|
| 503 | set f2 [debug 1] |
---|
| 504 | set f3 [debug] |
---|
| 505 | set f4 [debug 2] |
---|
| 506 | set f5 [debug] |
---|
| 507 | list $f1 $f2 $f3 $f4 $f5 |
---|
| 508 | } |
---|
| 509 | -result {0 1 1 2 2} |
---|
| 510 | -cleanup { |
---|
| 511 | set ::tcltest::debug $old |
---|
| 512 | } |
---|
| 513 | } |
---|
| 514 | removeFile test.tcl |
---|
| 515 | |
---|
| 516 | # directory tests |
---|
| 517 | |
---|
| 518 | set a [makeFile { |
---|
| 519 | package require tcltest |
---|
| 520 | tcltest::makeFile {} a.tmp |
---|
| 521 | puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]" |
---|
| 522 | exit |
---|
| 523 | } a.tcl] |
---|
| 524 | |
---|
| 525 | set tdiaf [makeFile {} thisdirectoryisafile] |
---|
| 526 | |
---|
| 527 | set normaldirectory [makeDirectory normaldirectory] |
---|
| 528 | normalizePath normaldirectory |
---|
| 529 | |
---|
| 530 | # -tmpdir, [temporaryDirectory] |
---|
| 531 | test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrPc -setup { |
---|
| 532 | file delete -force thisdirectorydoesnotexist |
---|
| 533 | } -body { |
---|
| 534 | slave msg $a -tmpdir thisdirectorydoesnotexist |
---|
| 535 | file exists [file join thisdirectorydoesnotexist a.tmp] |
---|
| 536 | } -cleanup { |
---|
| 537 | file delete -force thisdirectorydoesnotexist |
---|
| 538 | } -result 1 |
---|
| 539 | test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} { |
---|
| 540 | -constraints unixOrPc |
---|
| 541 | -body { |
---|
| 542 | slave msg $a -tmpdir $tdiaf |
---|
| 543 | return $msg |
---|
| 544 | } |
---|
| 545 | -result {*not a directory*} |
---|
| 546 | -match glob |
---|
| 547 | } |
---|
| 548 | # Test non-writeable directories, non-readable directories with directory flags |
---|
| 549 | set notReadableDir [file join [temporaryDirectory] notreadable] |
---|
| 550 | set notWriteableDir [file join [temporaryDirectory] notwriteable] |
---|
| 551 | makeDirectory notreadable |
---|
| 552 | makeDirectory notwriteable |
---|
| 553 | switch -- $::tcl_platform(platform) { |
---|
| 554 | "unix" { |
---|
| 555 | file attributes $notReadableDir -permissions 00333 |
---|
| 556 | file attributes $notWriteableDir -permissions 00555 |
---|
| 557 | } |
---|
| 558 | default { |
---|
| 559 | catch {file attributes $notWriteableDir -readonly 1} |
---|
| 560 | catch {testchmod 000 $notWriteableDir} |
---|
| 561 | } |
---|
| 562 | } |
---|
| 563 | test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} { |
---|
| 564 | -constraints {unix notRoot} |
---|
| 565 | -body { |
---|
| 566 | slave msg $a -tmpdir $notReadableDir |
---|
| 567 | return $msg |
---|
| 568 | } |
---|
| 569 | -result {*not readable*} |
---|
| 570 | -match glob |
---|
| 571 | } |
---|
| 572 | # This constraint doesn't go at the top of the file so that it doesn't |
---|
| 573 | # interfere with tcltest-5.5 |
---|
| 574 | testConstraint notFAT [expr { |
---|
| 575 | ![string match "FAT*" [lindex [file system $notWriteableDir] 1]] |
---|
| 576 | }] |
---|
| 577 | # FAT permissions are fairly hopeless; ignore this test if that FS is used |
---|
| 578 | test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} { |
---|
| 579 | -constraints {unixOrPc notRoot notFAT} |
---|
| 580 | -body { |
---|
| 581 | slave msg $a -tmpdir $notWriteableDir |
---|
| 582 | return $msg |
---|
| 583 | } |
---|
| 584 | -result {*not writeable*} |
---|
| 585 | -match glob |
---|
| 586 | } |
---|
| 587 | test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} { |
---|
| 588 | -constraints unixOrPc |
---|
| 589 | -body { |
---|
| 590 | slave msg $a -tmpdir $normaldirectory |
---|
| 591 | # The join is necessary because the message can be split on multiple |
---|
| 592 | # lines |
---|
| 593 | file exists [file join $normaldirectory a.tmp] |
---|
| 594 | } |
---|
| 595 | -cleanup { |
---|
| 596 | catch {file delete [file join $normaldirectory a.tmp]} |
---|
| 597 | } |
---|
| 598 | -result 1 |
---|
| 599 | } |
---|
| 600 | cd [workingDirectory] |
---|
| 601 | test tcltest-8.6 {temporaryDirectory} { |
---|
| 602 | -setup { |
---|
| 603 | set old $::tcltest::temporaryDirectory |
---|
| 604 | set ::tcltest::temporaryDirectory $normaldirectory |
---|
| 605 | } |
---|
| 606 | -body { |
---|
| 607 | set f1 [temporaryDirectory] |
---|
| 608 | set f2 [temporaryDirectory [workingDirectory]] |
---|
| 609 | set f3 [temporaryDirectory] |
---|
| 610 | list $f1 $f2 $f3 |
---|
| 611 | } |
---|
| 612 | -result "[list $normaldirectory [workingDirectory] [workingDirectory]]" |
---|
| 613 | -cleanup { |
---|
| 614 | set ::tcltest::temporaryDirectory $old |
---|
| 615 | } |
---|
| 616 | } |
---|
| 617 | test tcltest-8.6a {temporaryDirectory - test format 2} -setup { |
---|
| 618 | set old $::tcltest::temporaryDirectory |
---|
| 619 | set ::tcltest::temporaryDirectory $normaldirectory |
---|
| 620 | } -body { |
---|
| 621 | set f1 [temporaryDirectory] |
---|
| 622 | set f2 [temporaryDirectory [workingDirectory]] |
---|
| 623 | set f3 [temporaryDirectory] |
---|
| 624 | list $f1 $f2 $f3 |
---|
| 625 | } -cleanup { |
---|
| 626 | set ::tcltest::temporaryDirectory $old |
---|
| 627 | } -result [list $normaldirectory [workingDirectory] [workingDirectory]] |
---|
| 628 | cd [temporaryDirectory] |
---|
| 629 | # -testdir, [testsDirectory] |
---|
| 630 | test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} { |
---|
| 631 | -constraints unixOrPc |
---|
| 632 | -setup { |
---|
| 633 | file delete -force thisdirectorydoesnotexist |
---|
| 634 | } |
---|
| 635 | -body { |
---|
| 636 | slave msg $a -testdir thisdirectorydoesnotexist |
---|
| 637 | return $msg |
---|
| 638 | } |
---|
| 639 | -match glob |
---|
| 640 | -result {*does not exist*} |
---|
| 641 | } |
---|
| 642 | test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} { |
---|
| 643 | -constraints unixOrPc |
---|
| 644 | -body { |
---|
| 645 | slave msg $a -testdir $tdiaf |
---|
| 646 | return $msg |
---|
| 647 | } |
---|
| 648 | -match glob |
---|
| 649 | -result {*not a directory*} |
---|
| 650 | } |
---|
| 651 | test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} { |
---|
| 652 | -constraints {unix notRoot} |
---|
| 653 | -body { |
---|
| 654 | slave msg $a -testdir $notReadableDir |
---|
| 655 | return $msg |
---|
| 656 | } |
---|
| 657 | -match glob |
---|
| 658 | -result {*not readable*} |
---|
| 659 | } |
---|
| 660 | test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} { |
---|
| 661 | -constraints unixOrPc |
---|
| 662 | -body { |
---|
| 663 | slave msg $a -testdir $normaldirectory |
---|
| 664 | # The join is necessary because the message can be split on multiple |
---|
| 665 | # lines |
---|
| 666 | list [string first "testdir: $normaldirectory" [join $msg]] \ |
---|
| 667 | [file exists [file join [temporaryDirectory] a.tmp]] |
---|
| 668 | } |
---|
| 669 | -cleanup { |
---|
| 670 | file delete [file join [temporaryDirectory] a.tmp] |
---|
| 671 | } |
---|
| 672 | -result {0 1} |
---|
| 673 | } |
---|
| 674 | cd [workingDirectory] |
---|
| 675 | set current [pwd] |
---|
| 676 | test tcltest-8.14 {testsDirectory} { |
---|
| 677 | -setup { |
---|
| 678 | set old $::tcltest::testsDirectory |
---|
| 679 | set ::tcltest::testsDirectory $normaldirectory |
---|
| 680 | } |
---|
| 681 | -body { |
---|
| 682 | set f1 [testsDirectory] |
---|
| 683 | set f2 [testsDirectory $current] |
---|
| 684 | set f3 [testsDirectory] |
---|
| 685 | list $f1 $f2 $f3 |
---|
| 686 | } |
---|
| 687 | -result "[list $normaldirectory $current $current]" |
---|
| 688 | -cleanup { |
---|
| 689 | set ::tcltest::testsDirectory $old |
---|
| 690 | } |
---|
| 691 | } |
---|
| 692 | # [workingDirectory] |
---|
| 693 | test tcltest-8.60 {::workingDirectory} { |
---|
| 694 | -setup { |
---|
| 695 | set old $::tcltest::workingDirectory |
---|
| 696 | set current [pwd] |
---|
| 697 | set ::tcltest::workingDirectory $normaldirectory |
---|
| 698 | cd $normaldirectory |
---|
| 699 | } |
---|
| 700 | -body { |
---|
| 701 | set f1 [workingDirectory] |
---|
| 702 | set f2 [pwd] |
---|
| 703 | set f3 [workingDirectory $current] |
---|
| 704 | set f4 [pwd] |
---|
| 705 | set f5 [workingDirectory] |
---|
| 706 | list $f1 $f2 $f3 $f4 $f5 |
---|
| 707 | } |
---|
| 708 | -result "[list $normaldirectory \ |
---|
| 709 | $normaldirectory \ |
---|
| 710 | $current \ |
---|
| 711 | $current \ |
---|
| 712 | $current]" |
---|
| 713 | -cleanup { |
---|
| 714 | set ::tcltest::workingDirectory $old |
---|
| 715 | cd $current |
---|
| 716 | } |
---|
| 717 | } |
---|
| 718 | |
---|
| 719 | # clean up from directory testing |
---|
| 720 | |
---|
| 721 | switch $::tcl_platform(platform) { |
---|
| 722 | "unix" { |
---|
| 723 | file attributes $notReadableDir -permissions 777 |
---|
| 724 | file attributes $notWriteableDir -permissions 777 |
---|
| 725 | } |
---|
| 726 | default { |
---|
| 727 | catch {file attributes $notWriteableDir -readonly 0} |
---|
| 728 | } |
---|
| 729 | } |
---|
| 730 | |
---|
| 731 | file delete -force $notReadableDir $notWriteableDir |
---|
| 732 | removeFile a.tcl |
---|
| 733 | removeFile thisdirectoryisafile |
---|
| 734 | removeDirectory normaldirectory |
---|
| 735 | |
---|
| 736 | # -file, -notfile, [matchFiles], [skipFiles] |
---|
| 737 | test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup { |
---|
| 738 | set old [testsDirectory] |
---|
| 739 | testsDirectory [file dirname [info script]] |
---|
| 740 | } -body { |
---|
| 741 | slave msg [file join [testsDirectory] all.tcl] -file d*.test |
---|
| 742 | return $msg |
---|
| 743 | } -cleanup { |
---|
| 744 | testsDirectory $old |
---|
| 745 | } -match regexp -result {dstring\.test} |
---|
| 746 | |
---|
| 747 | test tcltest-9.2 {-file d*.tcl} -constraints {unixOrPc} -setup { |
---|
| 748 | set old [testsDirectory] |
---|
| 749 | testsDirectory [file dirname [info script]] |
---|
| 750 | } -body { |
---|
| 751 | slave msg [file join [testsDirectory] all.tcl] \ |
---|
| 752 | -file d*.test -notfile dstring* |
---|
| 753 | regexp {dstring\.test} $msg |
---|
| 754 | } -cleanup { |
---|
| 755 | testsDirectory $old |
---|
| 756 | } -result 0 |
---|
| 757 | |
---|
| 758 | test tcltest-9.3 {matchFiles} { |
---|
| 759 | -body { |
---|
| 760 | set old [matchFiles] |
---|
| 761 | matchFiles foo |
---|
| 762 | set current [matchFiles] |
---|
| 763 | matchFiles bar |
---|
| 764 | set new [matchFiles] |
---|
| 765 | matchFiles $old |
---|
| 766 | list $current $new |
---|
| 767 | } |
---|
| 768 | -result {foo bar} |
---|
| 769 | } |
---|
| 770 | |
---|
| 771 | test tcltest-9.4 {skipFiles} { |
---|
| 772 | -body { |
---|
| 773 | set old [skipFiles] |
---|
| 774 | skipFiles foo |
---|
| 775 | set current [skipFiles] |
---|
| 776 | skipFiles bar |
---|
| 777 | set new [skipFiles] |
---|
| 778 | skipFiles $old |
---|
| 779 | list $current $new |
---|
| 780 | } |
---|
| 781 | -result {foo bar} |
---|
| 782 | } |
---|
| 783 | |
---|
| 784 | test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup { |
---|
| 785 | set d [makeDirectory tmp] |
---|
| 786 | makeDirectory foo $d |
---|
| 787 | makeFile {} fee $d |
---|
| 788 | file copy [file join [file dirname [info script]] all.tcl] $d |
---|
| 789 | } -body { |
---|
| 790 | slave msg [file join [temporaryDirectory] all.tcl] -file f* |
---|
| 791 | regexp {exiting with errors:} $msg |
---|
| 792 | } -cleanup { |
---|
| 793 | file delete [file join $d all.tcl] |
---|
| 794 | removeFile fee $d |
---|
| 795 | removeDirectory foo $d |
---|
| 796 | removeDirectory tmp |
---|
| 797 | } -result 0 |
---|
| 798 | |
---|
| 799 | # -preservecore, [preserveCore] |
---|
| 800 | set mc [makeFile { |
---|
| 801 | package require tcltest |
---|
| 802 | namespace import ::tcltest::test |
---|
| 803 | test makecore {make a core file} { |
---|
| 804 | set f [open core w] |
---|
| 805 | close $f |
---|
| 806 | } {} |
---|
| 807 | ::tcltest::cleanupTests |
---|
| 808 | return |
---|
| 809 | } makecore.tcl] |
---|
| 810 | |
---|
| 811 | cd [temporaryDirectory] |
---|
| 812 | test tcltest-10.1 {-preservecore 0} {unixOrPc} { |
---|
| 813 | slave msg $mc -preservecore 0 |
---|
| 814 | file delete core |
---|
| 815 | regexp "Core file produced" $msg |
---|
| 816 | } {0} |
---|
| 817 | test tcltest-10.2 {-preservecore 1} {unixOrPc} { |
---|
| 818 | slave msg $mc -preservecore 1 |
---|
| 819 | file delete core |
---|
| 820 | regexp "Core file produced" $msg |
---|
| 821 | } {1} |
---|
| 822 | test tcltest-10.3 {-preservecore 2} {unixOrPc} { |
---|
| 823 | slave msg $mc -preservecore 2 |
---|
| 824 | file delete core |
---|
| 825 | list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \ |
---|
| 826 | [regexp "core-" $msg] [file delete core-makecore] |
---|
| 827 | } {1 1 1 {}} |
---|
| 828 | test tcltest-10.4 {-preservecore 3} {unixOrPc} { |
---|
| 829 | slave msg $mc -preservecore 3 |
---|
| 830 | file delete core |
---|
| 831 | list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \ |
---|
| 832 | [regexp "core-" $msg] [file delete core-makecore] |
---|
| 833 | } {1 1 1 {}} |
---|
| 834 | |
---|
| 835 | # Removing this test. It makes no sense to test the ability of |
---|
| 836 | # [preserveCore] to accept an invalid value that will cause errors |
---|
| 837 | # in other parts of tcltest's operation. |
---|
| 838 | #test tcltest-10.5 {preserveCore} { |
---|
| 839 | # -body { |
---|
| 840 | # set old [preserveCore] |
---|
| 841 | # set result [preserveCore foo] |
---|
| 842 | # set result2 [preserveCore] |
---|
| 843 | # preserveCore $old |
---|
| 844 | # list $result $result2 |
---|
| 845 | # } |
---|
| 846 | # -result {foo foo} |
---|
| 847 | #} |
---|
| 848 | removeFile makecore.tcl |
---|
| 849 | |
---|
| 850 | # -load, -loadfile, [loadScript], [loadFile] |
---|
| 851 | set contents { |
---|
| 852 | package require tcltest |
---|
| 853 | namespace import tcltest::* |
---|
| 854 | puts [outputChannel] $::tcltest::loadScript |
---|
| 855 | exit |
---|
| 856 | } |
---|
| 857 | set loadfile [makeFile $contents load.tcl] |
---|
| 858 | |
---|
| 859 | test tcltest-12.1 {-load xxx} {unixOrPc} { |
---|
| 860 | slave msg $loadfile -load xxx |
---|
| 861 | return $msg |
---|
| 862 | } {xxx} |
---|
| 863 | |
---|
| 864 | # Using child process because of -debug usage. |
---|
| 865 | test tcltest-12.2 {-loadfile load.tcl} {unixOrPc} { |
---|
| 866 | catch {exec [interpreter] $loadfile -debug 2 -loadfile $loadfile} msg |
---|
| 867 | list \ |
---|
| 868 | [regexp {tcltest} [join [list $msg] [split $msg \n]]] \ |
---|
| 869 | [regexp {loadScript} [join [list $msg] [split $msg \n]]] |
---|
| 870 | } {1 1} |
---|
| 871 | |
---|
| 872 | test tcltest-12.3 {loadScript} { |
---|
| 873 | -setup { |
---|
| 874 | set old $::tcltest::loadScript |
---|
| 875 | set ::tcltest::loadScript {} |
---|
| 876 | } |
---|
| 877 | -body { |
---|
| 878 | set f1 [loadScript] |
---|
| 879 | set f2 [loadScript xxx] |
---|
| 880 | set f3 [loadScript] |
---|
| 881 | list $f1 $f2 $f3 |
---|
| 882 | } |
---|
| 883 | -result {{} xxx xxx} |
---|
| 884 | -cleanup { |
---|
| 885 | set ::tcltest::loadScript $old |
---|
| 886 | } |
---|
| 887 | } |
---|
| 888 | |
---|
| 889 | test tcltest-12.4 {loadFile} { |
---|
| 890 | -setup { |
---|
| 891 | set olds $::tcltest::loadScript |
---|
| 892 | set ::tcltest::loadScript {} |
---|
| 893 | set oldf $::tcltest::loadFile |
---|
| 894 | set ::tcltest::loadFile {} |
---|
| 895 | } |
---|
| 896 | -body { |
---|
| 897 | set f1 [loadScript] |
---|
| 898 | set f2 [loadFile] |
---|
| 899 | set f3 [loadFile $loadfile] |
---|
| 900 | set f4 [loadScript] |
---|
| 901 | set f5 [loadFile] |
---|
| 902 | list $f1 $f2 $f3 $f4 $f5 |
---|
| 903 | } |
---|
| 904 | -result "[list {} {} $loadfile $contents $loadfile]\n" |
---|
| 905 | -cleanup { |
---|
| 906 | set ::tcltest::loadScript $olds |
---|
| 907 | set ::tcltest::loadFile $oldf |
---|
| 908 | } |
---|
| 909 | } |
---|
| 910 | removeFile load.tcl |
---|
| 911 | |
---|
| 912 | # [interpreter] |
---|
| 913 | test tcltest-13.1 {interpreter} { |
---|
| 914 | -setup { |
---|
| 915 | set old $::tcltest::tcltest |
---|
| 916 | set ::tcltest::tcltest tcltest |
---|
| 917 | } |
---|
| 918 | -body { |
---|
| 919 | set f1 [interpreter] |
---|
| 920 | set f2 [interpreter tclsh] |
---|
| 921 | set f3 [interpreter] |
---|
| 922 | list $f1 $f2 $f3 |
---|
| 923 | } |
---|
| 924 | -result {tcltest tclsh tclsh} |
---|
| 925 | -cleanup { |
---|
| 926 | set ::tcltest::tcltest $old |
---|
| 927 | } |
---|
| 928 | } |
---|
| 929 | |
---|
| 930 | # -singleproc, [singleProcess] |
---|
| 931 | set spd [makeDirectory singleprocdir] |
---|
| 932 | makeFile { |
---|
| 933 | set foo 1 |
---|
| 934 | } single1.test $spd |
---|
| 935 | |
---|
| 936 | makeFile { |
---|
| 937 | unset foo |
---|
| 938 | } single2.test $spd |
---|
| 939 | |
---|
| 940 | set allfile [makeFile { |
---|
| 941 | package require tcltest |
---|
| 942 | namespace import tcltest::* |
---|
| 943 | testsDirectory [file join [temporaryDirectory] singleprocdir] |
---|
| 944 | runAllTests |
---|
| 945 | } all-single.tcl $spd] |
---|
| 946 | cd [workingDirectory] |
---|
| 947 | |
---|
| 948 | test tcltest-14.1 {-singleproc - single process} { |
---|
| 949 | -constraints {unixOrPc} |
---|
| 950 | -body { |
---|
| 951 | slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory] |
---|
| 952 | return $msg |
---|
| 953 | } |
---|
| 954 | -result {Test file error: can't unset .foo.: no such variable} |
---|
| 955 | -match regexp |
---|
| 956 | } |
---|
| 957 | |
---|
| 958 | test tcltest-14.2 {-singleproc - multiple process} { |
---|
| 959 | -constraints {unixOrPc} |
---|
| 960 | -body { |
---|
| 961 | slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory] |
---|
| 962 | return $msg |
---|
| 963 | } |
---|
| 964 | -result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0} |
---|
| 965 | -match regexp |
---|
| 966 | } |
---|
| 967 | |
---|
| 968 | test tcltest-14.3 {singleProcess} { |
---|
| 969 | -setup { |
---|
| 970 | set old $::tcltest::singleProcess |
---|
| 971 | set ::tcltest::singleProcess 0 |
---|
| 972 | } |
---|
| 973 | -body { |
---|
| 974 | set f1 [singleProcess] |
---|
| 975 | set f2 [singleProcess 1] |
---|
| 976 | set f3 [singleProcess] |
---|
| 977 | list $f1 $f2 $f3 |
---|
| 978 | } |
---|
| 979 | -result {0 1 1} |
---|
| 980 | -cleanup { |
---|
| 981 | set ::tcltest::singleProcess $old |
---|
| 982 | } |
---|
| 983 | } |
---|
| 984 | removeFile single1.test $spd |
---|
| 985 | removeFile single2.test $spd |
---|
| 986 | removeDirectory singleprocdir |
---|
| 987 | |
---|
| 988 | # -asidefromdir, -relateddir, [matchDirectories], [skipDirectories] |
---|
| 989 | |
---|
| 990 | # Before running these tests, need to set up test subdirectories with their own |
---|
| 991 | # all.tcl files. |
---|
| 992 | |
---|
| 993 | set dtd [makeDirectory dirtestdir] |
---|
| 994 | set dtd1 [makeDirectory dirtestdir2.1 $dtd] |
---|
| 995 | set dtd2 [makeDirectory dirtestdir2.2 $dtd] |
---|
| 996 | set dtd3 [makeDirectory dirtestdir2.3 $dtd] |
---|
| 997 | makeFile { |
---|
| 998 | package require tcltest |
---|
| 999 | namespace import -force tcltest::* |
---|
| 1000 | testsDirectory [file join [temporaryDirectory] dirtestdir] |
---|
| 1001 | runAllTests |
---|
| 1002 | } all.tcl $dtd |
---|
| 1003 | makeFile { |
---|
| 1004 | package require tcltest |
---|
| 1005 | namespace import -force tcltest::* |
---|
| 1006 | testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.1] |
---|
| 1007 | runAllTests |
---|
| 1008 | } all.tcl $dtd1 |
---|
| 1009 | makeFile { |
---|
| 1010 | package require tcltest |
---|
| 1011 | namespace import -force tcltest::* |
---|
| 1012 | testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.2] |
---|
| 1013 | runAllTests |
---|
| 1014 | } all.tcl $dtd2 |
---|
| 1015 | makeFile { |
---|
| 1016 | package require tcltest |
---|
| 1017 | namespace import -force tcltest::* |
---|
| 1018 | testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3] |
---|
| 1019 | runAllTests |
---|
| 1020 | } all.tcl $dtd3 |
---|
| 1021 | |
---|
| 1022 | test tcltest-15.1 {basic directory walking} { |
---|
| 1023 | -constraints {unixOrPc} |
---|
| 1024 | -body { |
---|
| 1025 | if {[slave msg \ |
---|
| 1026 | [file join $dtd all.tcl] \ |
---|
| 1027 | -tmpdir [temporaryDirectory]] == 1} { |
---|
| 1028 | error $msg |
---|
| 1029 | } |
---|
| 1030 | } |
---|
| 1031 | -match regexp |
---|
| 1032 | -returnCodes 1 |
---|
| 1033 | -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123]} |
---|
| 1034 | } |
---|
| 1035 | |
---|
| 1036 | test tcltest-15.2 {-asidefromdir} { |
---|
| 1037 | -constraints {unixOrPc} |
---|
| 1038 | -body { |
---|
| 1039 | if {[slave msg \ |
---|
| 1040 | [file join $dtd all.tcl] \ |
---|
| 1041 | -asidefromdir dirtestdir2.3 \ |
---|
| 1042 | -tmpdir [temporaryDirectory]] == 1} { |
---|
| 1043 | error $msg |
---|
| 1044 | } |
---|
| 1045 | } |
---|
| 1046 | -match regexp |
---|
| 1047 | -returnCodes 1 |
---|
| 1048 | -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.[12].*Tests located in:.*dirtestdir2.[12].*dirtestdir2.[12] test ended at .*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
| 1049 | Error: No test files remain after applying your match and skip patterns! |
---|
| 1050 | Error: No test files remain after applying your match and skip patterns! |
---|
| 1051 | Error: No test files remain after applying your match and skip patterns!$} |
---|
| 1052 | } |
---|
| 1053 | |
---|
| 1054 | test tcltest-15.3 {-relateddir, non-existent dir} { |
---|
| 1055 | -constraints {unixOrPc} |
---|
| 1056 | -body { |
---|
| 1057 | if {[slave msg \ |
---|
| 1058 | [file join $dtd all.tcl] \ |
---|
| 1059 | -relateddir [file join [temporaryDirectory] dirtestdir0] \ |
---|
| 1060 | -tmpdir [temporaryDirectory]] == 1} { |
---|
| 1061 | error $msg |
---|
| 1062 | } |
---|
| 1063 | } |
---|
| 1064 | -returnCodes 1 |
---|
| 1065 | -match regexp |
---|
| 1066 | -result {[^~]|dirtestdir[^2]} |
---|
| 1067 | } |
---|
| 1068 | |
---|
| 1069 | test tcltest-15.4 {-relateddir, subdir} { |
---|
| 1070 | -constraints {unixOrPc} |
---|
| 1071 | -body { |
---|
| 1072 | if {[slave msg \ |
---|
| 1073 | [file join $dtd all.tcl] \ |
---|
| 1074 | -relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} { |
---|
| 1075 | error $msg |
---|
| 1076 | } |
---|
| 1077 | } |
---|
| 1078 | -returnCodes 1 |
---|
| 1079 | -match regexp |
---|
| 1080 | -result {Tests located in:.*dirtestdir2.[^23]} |
---|
| 1081 | } |
---|
| 1082 | test tcltest-15.5 {-relateddir, -asidefromdir} { |
---|
| 1083 | -constraints {unixOrPc} |
---|
| 1084 | -body { |
---|
| 1085 | if {[slave msg \ |
---|
| 1086 | [file join $dtd all.tcl] \ |
---|
| 1087 | -relateddir "dirtestdir2.1 dirtestdir2.2" \ |
---|
| 1088 | -asidefromdir dirtestdir2.2 \ |
---|
| 1089 | -tmpdir [temporaryDirectory]] == 1} { |
---|
| 1090 | error $msg |
---|
| 1091 | } |
---|
| 1092 | } |
---|
| 1093 | -match regexp |
---|
| 1094 | -returnCodes 1 |
---|
| 1095 | -result {Tests located in:.*dirtestdir2.[^23]} |
---|
| 1096 | } |
---|
| 1097 | |
---|
| 1098 | test tcltest-15.6 {matchDirectories} { |
---|
| 1099 | -setup { |
---|
| 1100 | set old [matchDirectories] |
---|
| 1101 | set ::tcltest::matchDirectories {} |
---|
| 1102 | } |
---|
| 1103 | -body { |
---|
| 1104 | set r1 [matchDirectories] |
---|
| 1105 | set r2 [matchDirectories foo] |
---|
| 1106 | set r3 [matchDirectories] |
---|
| 1107 | list $r1 $r2 $r3 |
---|
| 1108 | } |
---|
| 1109 | -cleanup { |
---|
| 1110 | set ::tcltest::matchDirectories $old |
---|
| 1111 | } |
---|
| 1112 | -result {{} foo foo} |
---|
| 1113 | } |
---|
| 1114 | |
---|
| 1115 | test tcltest-15.7 {skipDirectories} { |
---|
| 1116 | -setup { |
---|
| 1117 | set old [skipDirectories] |
---|
| 1118 | set ::tcltest::skipDirectories {} |
---|
| 1119 | } |
---|
| 1120 | -body { |
---|
| 1121 | set r1 [skipDirectories] |
---|
| 1122 | set r2 [skipDirectories foo] |
---|
| 1123 | set r3 [skipDirectories] |
---|
| 1124 | list $r1 $r2 $r3 |
---|
| 1125 | } |
---|
| 1126 | -cleanup { |
---|
| 1127 | set ::tcltest::skipDirectories $old |
---|
| 1128 | } |
---|
| 1129 | -result {{} foo foo} |
---|
| 1130 | } |
---|
| 1131 | removeDirectory dirtestdir2.3 $dtd |
---|
| 1132 | removeDirectory dirtestdir2.2 $dtd |
---|
| 1133 | removeDirectory dirtestdir2.1 $dtd |
---|
| 1134 | removeDirectory dirtestdir |
---|
| 1135 | |
---|
| 1136 | # TCLTEST_OPTIONS |
---|
| 1137 | test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { |
---|
| 1138 | if {[info exists ::env(TCLTEST_OPTIONS)]} { |
---|
| 1139 | set oldoptions $::env(TCLTEST_OPTIONS) |
---|
| 1140 | } else { |
---|
| 1141 | set oldoptions none |
---|
| 1142 | } |
---|
| 1143 | # set this to { } instead of just {} to get around quirk in |
---|
| 1144 | # Windows env handling that removes empty elements from env array. |
---|
| 1145 | set ::env(TCLTEST_OPTIONS) { } |
---|
| 1146 | interp create slave1 |
---|
| 1147 | slave1 eval [list set argv {-debug 2}] |
---|
| 1148 | slave1 alias puts puts |
---|
| 1149 | interp create slave2 |
---|
| 1150 | slave2 alias puts puts |
---|
| 1151 | } -cleanup { |
---|
| 1152 | interp delete slave2 |
---|
| 1153 | interp delete slave1 |
---|
| 1154 | if {$oldoptions == "none"} { |
---|
| 1155 | unset ::env(TCLTEST_OPTIONS) |
---|
| 1156 | } else { |
---|
| 1157 | set ::env(TCLTEST_OPTIONS) $oldoptions |
---|
| 1158 | } |
---|
| 1159 | } -body { |
---|
| 1160 | slave1 eval [package ifneeded tcltest [package provide tcltest]] |
---|
| 1161 | slave1 eval tcltest::debug |
---|
| 1162 | set ::env(TCLTEST_OPTIONS) "-debug 3" |
---|
| 1163 | slave2 eval [package ifneeded tcltest [package provide tcltest]] |
---|
| 1164 | slave2 eval tcltest::debug |
---|
| 1165 | } -result {^3$} -match regexp -output\ |
---|
| 1166 | {tcltest::debug\s+= 2.*tcltest::debug\s+= 3} |
---|
| 1167 | |
---|
| 1168 | # Begin testing of tcltest procs ... |
---|
| 1169 | |
---|
| 1170 | cd [temporaryDirectory] |
---|
| 1171 | # PrintError |
---|
| 1172 | test tcltest-20.1 {PrintError} {unixOrPc} { |
---|
| 1173 | set result [slave msg $printerror] |
---|
| 1174 | list $result [regexp "Error: a really short string" $msg] \ |
---|
| 1175 | [regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \ |
---|
| 1176 | [regexp " \"Really" $msg] [regexp Problem $msg] |
---|
| 1177 | } {1 1 1 1 1 1} |
---|
| 1178 | cd [workingDirectory] |
---|
| 1179 | removeFile printerror.tcl |
---|
| 1180 | |
---|
| 1181 | # test::test |
---|
| 1182 | test tcltest-21.0 {name and desc but no args specified} -setup { |
---|
| 1183 | set v [verbose] |
---|
| 1184 | } -cleanup { |
---|
| 1185 | verbose $v |
---|
| 1186 | } -body { |
---|
| 1187 | verbose {} |
---|
| 1188 | test tcltest-21.0.0 bar |
---|
| 1189 | } -result {} |
---|
| 1190 | |
---|
| 1191 | test tcltest-21.1 {expect with glob} { |
---|
| 1192 | -body { |
---|
| 1193 | list a b c d e |
---|
| 1194 | } |
---|
| 1195 | -match glob |
---|
| 1196 | -result {[ab] b c d e} |
---|
| 1197 | } |
---|
| 1198 | |
---|
| 1199 | test tcltest-21.2 {force a test command failure} { |
---|
| 1200 | -body { |
---|
| 1201 | test tcltest-21.2.0 { |
---|
| 1202 | return 2 |
---|
| 1203 | } {1} |
---|
| 1204 | } |
---|
| 1205 | -returnCodes 1 |
---|
| 1206 | -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} |
---|
| 1207 | } |
---|
| 1208 | |
---|
| 1209 | test tcltest-21.3 {test command with setup} { |
---|
| 1210 | -setup { |
---|
| 1211 | set foo 1 |
---|
| 1212 | } |
---|
| 1213 | -body { |
---|
| 1214 | set foo |
---|
| 1215 | } |
---|
| 1216 | -cleanup {unset foo} |
---|
| 1217 | -result {1} |
---|
| 1218 | } |
---|
| 1219 | |
---|
| 1220 | test tcltest-21.4 {test command with cleanup failure} { |
---|
| 1221 | -setup { |
---|
| 1222 | if {[info exists foo]} { |
---|
| 1223 | unset foo |
---|
| 1224 | } |
---|
| 1225 | set fail $::tcltest::currentFailure |
---|
| 1226 | set v [verbose] |
---|
| 1227 | } |
---|
| 1228 | -body { |
---|
| 1229 | verbose {} |
---|
| 1230 | test tcltest-21.4.0 {foo-1} { |
---|
| 1231 | -cleanup {unset foo} |
---|
| 1232 | } |
---|
| 1233 | } |
---|
| 1234 | -result {^$} |
---|
| 1235 | -match regexp |
---|
| 1236 | -cleanup {verbose $v; set ::tcltest::currentFailure $fail} |
---|
| 1237 | -output "Test cleanup failed:.*can't unset \"foo\": no such variable" |
---|
| 1238 | } |
---|
| 1239 | |
---|
| 1240 | test tcltest-21.5 {test command with setup failure} { |
---|
| 1241 | -setup { |
---|
| 1242 | if {[info exists foo]} { |
---|
| 1243 | unset foo |
---|
| 1244 | } |
---|
| 1245 | set fail $::tcltest::currentFailure |
---|
| 1246 | } |
---|
| 1247 | -body { |
---|
| 1248 | test tcltest-21.5.0 {foo-2} { |
---|
| 1249 | -setup {unset foo} |
---|
| 1250 | } |
---|
| 1251 | } |
---|
| 1252 | -result {^$} |
---|
| 1253 | -match regexp |
---|
| 1254 | -cleanup {set ::tcltest::currentFailure $fail} |
---|
| 1255 | -output "Test setup failed:.*can't unset \"foo\": no such variable" |
---|
| 1256 | } |
---|
| 1257 | |
---|
| 1258 | test tcltest-21.6 {test command - setup occurs before cleanup & before script} { |
---|
| 1259 | -setup {set v [verbose]; set fail $::tcltest::currentFailure} |
---|
| 1260 | -body { |
---|
| 1261 | verbose {} |
---|
| 1262 | test tcltest-21.6.0 {foo-3} { |
---|
| 1263 | -setup { |
---|
| 1264 | if {[info exists foo]} { |
---|
| 1265 | unset foo |
---|
| 1266 | } |
---|
| 1267 | set foo 1 |
---|
| 1268 | set expected 2 |
---|
| 1269 | } |
---|
| 1270 | -body { |
---|
| 1271 | incr foo |
---|
| 1272 | set foo |
---|
| 1273 | } |
---|
| 1274 | -cleanup { |
---|
| 1275 | if {$foo != 2} { |
---|
| 1276 | puts [outputChannel] "foo is wrong" |
---|
| 1277 | } else { |
---|
| 1278 | puts [outputChannel] "foo is 2" |
---|
| 1279 | } |
---|
| 1280 | } |
---|
| 1281 | -result {$expected} |
---|
| 1282 | } |
---|
| 1283 | } |
---|
| 1284 | -cleanup {verbose $v; set ::tcltest::currentFailure $fail} |
---|
| 1285 | -result {^$} |
---|
| 1286 | -match regexp |
---|
| 1287 | -output "foo is 2" |
---|
| 1288 | } |
---|
| 1289 | |
---|
| 1290 | test tcltest-21.7 {test command - bad flag} { |
---|
| 1291 | -setup {set fail $::tcltest::currentFailure} |
---|
| 1292 | -cleanup {set ::tcltest::currentFailure $fail} |
---|
| 1293 | -body { |
---|
| 1294 | test tcltest-21.7.0 {foo-4} { |
---|
| 1295 | -foobar {} |
---|
| 1296 | } |
---|
| 1297 | } |
---|
| 1298 | -returnCodes 1 |
---|
| 1299 | -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} |
---|
| 1300 | } |
---|
| 1301 | |
---|
| 1302 | # alternate test command format (these are the same as 21.1-21.6, with the |
---|
| 1303 | # exception of being in the all-inline format) |
---|
| 1304 | |
---|
| 1305 | test tcltest-21.7a {expect with glob} \ |
---|
| 1306 | -body {list a b c d e} \ |
---|
| 1307 | -result {[ab] b c d e} \ |
---|
| 1308 | -match glob |
---|
| 1309 | |
---|
| 1310 | test tcltest-21.8 {force a test command failure} \ |
---|
| 1311 | -setup {set fail $::tcltest::currentFailure} \ |
---|
| 1312 | -body { |
---|
| 1313 | test tcltest-21.8.0 { |
---|
| 1314 | return 2 |
---|
| 1315 | } {1} |
---|
| 1316 | } \ |
---|
| 1317 | -returnCodes 1 \ |
---|
| 1318 | -cleanup {set ::tcltest::currentFailure $fail} \ |
---|
| 1319 | -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} |
---|
| 1320 | |
---|
| 1321 | test tcltest-21.9 {test command with setup} \ |
---|
| 1322 | -setup {set foo 1} \ |
---|
| 1323 | -body {set foo} \ |
---|
| 1324 | -cleanup {unset foo} \ |
---|
| 1325 | -result {1} |
---|
| 1326 | |
---|
| 1327 | test tcltest-21.10 {test command with cleanup failure} -setup { |
---|
| 1328 | if {[info exists foo]} { |
---|
| 1329 | unset foo |
---|
| 1330 | } |
---|
| 1331 | set fail $::tcltest::currentFailure |
---|
| 1332 | set v [verbose] |
---|
| 1333 | } -cleanup { |
---|
| 1334 | verbose $v |
---|
| 1335 | set ::tcltest::currentFailure $fail |
---|
| 1336 | } -body { |
---|
| 1337 | verbose {} |
---|
| 1338 | test tcltest-21.10.0 {foo-1} -cleanup {unset foo} |
---|
| 1339 | } -result {^$} -match regexp \ |
---|
| 1340 | -output {Test cleanup failed:.*can't unset \"foo\": no such variable} |
---|
| 1341 | |
---|
| 1342 | test tcltest-21.11 {test command with setup failure} -setup { |
---|
| 1343 | if {[info exists foo]} { |
---|
| 1344 | unset foo |
---|
| 1345 | } |
---|
| 1346 | set fail $::tcltest::currentFailure |
---|
| 1347 | } -cleanup {set ::tcltest::currentFailure $fail} -body { |
---|
| 1348 | test tcltest-21.11.0 {foo-2} -setup {unset foo} |
---|
| 1349 | } -result {^$} -output {Test setup failed:.*can't unset \"foo\": no such variable} -match regexp |
---|
| 1350 | |
---|
| 1351 | test tcltest-21.12 { |
---|
| 1352 | test command - setup occurs before cleanup & before script |
---|
| 1353 | } -setup { |
---|
| 1354 | set fail $::tcltest::currentFailure |
---|
| 1355 | set v [verbose] |
---|
| 1356 | } -cleanup { |
---|
| 1357 | verbose $v |
---|
| 1358 | set ::tcltest::currentFailure $fail |
---|
| 1359 | } -body { |
---|
| 1360 | verbose {} |
---|
| 1361 | test tcltest-21.12.0 {foo-3} -setup { |
---|
| 1362 | if {[info exists foo]} { |
---|
| 1363 | unset foo |
---|
| 1364 | } |
---|
| 1365 | set foo 1 |
---|
| 1366 | set expected 2 |
---|
| 1367 | } -body { |
---|
| 1368 | incr foo |
---|
| 1369 | set foo |
---|
| 1370 | } -cleanup { |
---|
| 1371 | if {$foo != 2} { |
---|
| 1372 | puts [outputChannel] "foo is wrong" |
---|
| 1373 | } else { |
---|
| 1374 | puts [outputChannel] "foo is 2" |
---|
| 1375 | } |
---|
| 1376 | } -result {$expected} |
---|
| 1377 | } -result {^$} -output {foo is 2} -match regexp |
---|
| 1378 | |
---|
| 1379 | # test all.tcl usage (runAllTests); simulate .test file failure, as well as |
---|
| 1380 | # crashes to determine whether or not these errors are logged. |
---|
| 1381 | |
---|
| 1382 | set atd [makeDirectory alltestdir] |
---|
| 1383 | makeFile { |
---|
| 1384 | package require tcltest |
---|
| 1385 | namespace import -force tcltest::* |
---|
| 1386 | testsDirectory [file join [temporaryDirectory] alltestdir] |
---|
| 1387 | runAllTests |
---|
| 1388 | } all.tcl $atd |
---|
| 1389 | makeFile { |
---|
| 1390 | exit 1 |
---|
| 1391 | } exit.test $atd |
---|
| 1392 | makeFile { |
---|
| 1393 | error "throw an error" |
---|
| 1394 | } error.test $atd |
---|
| 1395 | makeFile { |
---|
| 1396 | package require tcltest |
---|
| 1397 | namespace import -force tcltest::* |
---|
| 1398 | test foo-1.1 {foo} { |
---|
| 1399 | -body { return 1 } |
---|
| 1400 | -result {1} |
---|
| 1401 | } |
---|
| 1402 | cleanupTests |
---|
| 1403 | } test.test $atd |
---|
| 1404 | |
---|
| 1405 | # Must use a child process because stdout/stderr parsing can't be |
---|
| 1406 | # duplicated in slave interp. |
---|
| 1407 | test tcltest-22.1 {runAllTests} { |
---|
| 1408 | -constraints {unixOrPc} |
---|
| 1409 | -body { |
---|
| 1410 | exec [interpreter] \ |
---|
| 1411 | [file join $atd all.tcl] \ |
---|
| 1412 | -verbose t -tmpdir [temporaryDirectory] |
---|
| 1413 | } |
---|
| 1414 | -match regexp |
---|
| 1415 | -result "Test files exiting with errors:.*error.test.*exit.test" |
---|
| 1416 | } |
---|
| 1417 | removeDirectory alltestdir |
---|
| 1418 | |
---|
| 1419 | # makeFile, removeFile, makeDirectory, removeDirectory, viewFile |
---|
| 1420 | test tcltest-23.1 {makeFile} { |
---|
| 1421 | -setup { |
---|
| 1422 | set mfdir [file join [temporaryDirectory] mfdir] |
---|
| 1423 | file mkdir $mfdir |
---|
| 1424 | } |
---|
| 1425 | -body { |
---|
| 1426 | makeFile {} t1.tmp |
---|
| 1427 | makeFile {} et1.tmp $mfdir |
---|
| 1428 | list [file exists [file join [temporaryDirectory] t1.tmp]] \ |
---|
| 1429 | [file exists [file join $mfdir et1.tmp]] |
---|
| 1430 | } |
---|
| 1431 | -cleanup { |
---|
| 1432 | file delete -force $mfdir \ |
---|
| 1433 | [file join [temporaryDirectory] t1.tmp] |
---|
| 1434 | } |
---|
| 1435 | -result {1 1} |
---|
| 1436 | } |
---|
| 1437 | test tcltest-23.2 {removeFile} { |
---|
| 1438 | -setup { |
---|
| 1439 | set mfdir [file join [temporaryDirectory] mfdir] |
---|
| 1440 | file mkdir $mfdir |
---|
| 1441 | makeFile {} t1.tmp |
---|
| 1442 | makeFile {} et1.tmp $mfdir |
---|
| 1443 | if {![file exists [file join [temporaryDirectory] t1.tmp]] || \ |
---|
| 1444 | ![file exists [file join $mfdir et1.tmp]]} { |
---|
| 1445 | error "file creation didn't work" |
---|
| 1446 | } |
---|
| 1447 | } |
---|
| 1448 | -body { |
---|
| 1449 | removeFile t1.tmp |
---|
| 1450 | removeFile et1.tmp $mfdir |
---|
| 1451 | list [file exists [file join [temporaryDirectory] t1.tmp]] \ |
---|
| 1452 | [file exists [file join $mfdir et1.tmp]] |
---|
| 1453 | } |
---|
| 1454 | -cleanup { |
---|
| 1455 | file delete -force $mfdir \ |
---|
| 1456 | [file join [temporaryDirectory] t1.tmp] |
---|
| 1457 | } |
---|
| 1458 | -result {0 0} |
---|
| 1459 | } |
---|
| 1460 | test tcltest-23.3 {makeDirectory} { |
---|
| 1461 | -body { |
---|
| 1462 | set mfdir [file join [temporaryDirectory] mfdir] |
---|
| 1463 | file mkdir $mfdir |
---|
| 1464 | makeDirectory d1 |
---|
| 1465 | makeDirectory d2 $mfdir |
---|
| 1466 | list [file exists [file join [temporaryDirectory] d1]] \ |
---|
| 1467 | [file exists [file join $mfdir d2]] |
---|
| 1468 | } |
---|
| 1469 | -cleanup { |
---|
| 1470 | file delete -force [file join [temporaryDirectory] d1] $mfdir |
---|
| 1471 | } |
---|
| 1472 | -result {1 1} |
---|
| 1473 | } |
---|
| 1474 | test tcltest-23.4 {removeDirectory} { |
---|
| 1475 | -setup { |
---|
| 1476 | set mfdir [makeDirectory mfdir] |
---|
| 1477 | makeDirectory t1 |
---|
| 1478 | makeDirectory t2 $mfdir |
---|
| 1479 | if {![file exists $mfdir] || \ |
---|
| 1480 | ![file exists [file join [temporaryDirectory] $mfdir t2]]} { |
---|
| 1481 | error "setup failed - directory not created" |
---|
| 1482 | } |
---|
| 1483 | } |
---|
| 1484 | -body { |
---|
| 1485 | removeDirectory t1 |
---|
| 1486 | removeDirectory t2 $mfdir |
---|
| 1487 | list [file exists [file join [temporaryDirectory] t1]] \ |
---|
| 1488 | [file exists [file join $mfdir t2]] |
---|
| 1489 | } |
---|
| 1490 | -result {0 0} |
---|
| 1491 | } |
---|
| 1492 | test tcltest-23.5 {viewFile} { |
---|
| 1493 | -body { |
---|
| 1494 | set mfdir [file join [temporaryDirectory] mfdir] |
---|
| 1495 | file mkdir $mfdir |
---|
| 1496 | makeFile {foobar} t1.tmp |
---|
| 1497 | makeFile {foobarbaz} t2.tmp $mfdir |
---|
| 1498 | list [viewFile t1.tmp] [viewFile t2.tmp $mfdir] |
---|
| 1499 | } |
---|
| 1500 | -result {foobar foobarbaz} |
---|
| 1501 | -cleanup { |
---|
| 1502 | file delete -force $mfdir |
---|
| 1503 | removeFile t1.tmp |
---|
| 1504 | } |
---|
| 1505 | } |
---|
| 1506 | |
---|
| 1507 | # customMatch |
---|
| 1508 | proc matchNegative { expected actual } { |
---|
| 1509 | set match 0 |
---|
| 1510 | foreach a $actual e $expected { |
---|
| 1511 | if { $a != $e } { |
---|
| 1512 | set match 1 |
---|
| 1513 | break |
---|
| 1514 | } |
---|
| 1515 | } |
---|
| 1516 | return $match |
---|
| 1517 | } |
---|
| 1518 | |
---|
| 1519 | test tcltest-24.0 { |
---|
| 1520 | customMatch: syntax |
---|
| 1521 | } -body { |
---|
| 1522 | list [catch {customMatch} result] $result |
---|
| 1523 | } -result [list 1 "wrong # args: should be \"customMatch mode script\""] |
---|
| 1524 | |
---|
| 1525 | test tcltest-24.1 { |
---|
| 1526 | customMatch: syntax |
---|
| 1527 | } -body { |
---|
| 1528 | list [catch {customMatch foo} result] $result |
---|
| 1529 | } -result [list 1 "wrong # args: should be \"customMatch mode script\""] |
---|
| 1530 | |
---|
| 1531 | test tcltest-24.2 { |
---|
| 1532 | customMatch: syntax |
---|
| 1533 | } -body { |
---|
| 1534 | list [catch {customMatch foo bar baz} result] $result |
---|
| 1535 | } -result [list 1 "wrong # args: should be \"customMatch mode script\""] |
---|
| 1536 | |
---|
| 1537 | test tcltest-24.3 { |
---|
| 1538 | customMatch: argument checking |
---|
| 1539 | } -body { |
---|
| 1540 | list [catch {customMatch bad "a \{ b"} result] $result |
---|
| 1541 | } -result [list 1 "invalid customMatch script; can't evaluate after completion"] |
---|
| 1542 | |
---|
| 1543 | test tcltest-24.4 { |
---|
| 1544 | test: valid -match values |
---|
| 1545 | } -body { |
---|
| 1546 | list [catch { |
---|
| 1547 | test tcltest-24.4.0 {} \ |
---|
| 1548 | -match [namespace current]::noSuchMode |
---|
| 1549 | } result] $result |
---|
| 1550 | } -match glob -result {1 *bad -match value*} |
---|
| 1551 | |
---|
| 1552 | test tcltest-24.5 { |
---|
| 1553 | test: valid -match values |
---|
| 1554 | } -setup { |
---|
| 1555 | customMatch [namespace current]::alwaysMatch "format 1 ;#" |
---|
| 1556 | } -body { |
---|
| 1557 | list [catch { |
---|
| 1558 | test tcltest-24.5.0 {} \ |
---|
| 1559 | -match [namespace current]::noSuchMode |
---|
| 1560 | } result] $result |
---|
| 1561 | } -match glob -result {1 *bad -match value*: must be *alwaysMatch,*} |
---|
| 1562 | |
---|
| 1563 | test tcltest-24.6 { |
---|
| 1564 | customMatch: -match script that always matches |
---|
| 1565 | } -setup { |
---|
| 1566 | customMatch [namespace current]::alwaysMatch "format 1 ;#" |
---|
| 1567 | set v [verbose] |
---|
| 1568 | } -body { |
---|
| 1569 | verbose {} |
---|
| 1570 | test tcltest-24.6.0 {} -match [namespace current]::alwaysMatch \ |
---|
| 1571 | -body {format 1} -result 0 |
---|
| 1572 | } -cleanup { |
---|
| 1573 | verbose $v |
---|
| 1574 | } -result {} -output {} -errorOutput {} |
---|
| 1575 | |
---|
| 1576 | test tcltest-24.7 { |
---|
| 1577 | customMatch: replace default -exact matching |
---|
| 1578 | } -setup { |
---|
| 1579 | set saveExactMatchScript $::tcltest::CustomMatch(exact) |
---|
| 1580 | customMatch exact "format 1 ;#" |
---|
| 1581 | set v [verbose] |
---|
| 1582 | } -body { |
---|
| 1583 | verbose {} |
---|
| 1584 | test tcltest-24.7.0 {} -body {format 1} -result 0 |
---|
| 1585 | } -cleanup { |
---|
| 1586 | verbose $v |
---|
| 1587 | customMatch exact $saveExactMatchScript |
---|
| 1588 | unset saveExactMatchScript |
---|
| 1589 | } -result {} -output {} |
---|
| 1590 | |
---|
| 1591 | test tcltest-24.9 { |
---|
| 1592 | customMatch: error during match |
---|
| 1593 | } -setup { |
---|
| 1594 | proc errorDuringMatch args {return -code error "match returned error"} |
---|
| 1595 | customMatch [namespace current]::errorDuringMatch \ |
---|
| 1596 | [namespace code errorDuringMatch] |
---|
| 1597 | set v [verbose] |
---|
| 1598 | set fail $::tcltest::currentFailure |
---|
| 1599 | } -body { |
---|
| 1600 | verbose {} |
---|
| 1601 | test tcltest-24.9.0 {} -match [namespace current]::errorDuringMatch |
---|
| 1602 | } -cleanup { |
---|
| 1603 | verbose $v |
---|
| 1604 | set ::tcltest::currentFailure $fail |
---|
| 1605 | } -match glob -result {} -output {*FAILED*match returned error*} |
---|
| 1606 | |
---|
| 1607 | test tcltest-24.10 { |
---|
| 1608 | customMatch: bad return from match command |
---|
| 1609 | } -setup { |
---|
| 1610 | proc nonBooleanReturn args {return foo} |
---|
| 1611 | customMatch nonBooleanReturn [namespace code nonBooleanReturn] |
---|
| 1612 | set v [verbose] |
---|
| 1613 | set fail $::tcltest::currentFailure |
---|
| 1614 | } -body { |
---|
| 1615 | verbose {} |
---|
| 1616 | test tcltest-24.10.0 {} -match nonBooleanReturn |
---|
| 1617 | } -cleanup { |
---|
| 1618 | verbose $v |
---|
| 1619 | set ::tcltest::currentFailure $fail |
---|
| 1620 | } -match glob -result {} -output {*FAILED*expected boolean value*} |
---|
| 1621 | |
---|
| 1622 | test tcltest-24.11 { |
---|
| 1623 | test: -match exact |
---|
| 1624 | } -body { |
---|
| 1625 | set result {A B C} |
---|
| 1626 | } -match exact -result {A B C} |
---|
| 1627 | |
---|
| 1628 | test tcltest-24.12 { |
---|
| 1629 | test: -match exact match command eval in ::, not caller namespace |
---|
| 1630 | } -setup { |
---|
| 1631 | set saveExactMatchScript $::tcltest::CustomMatch(exact) |
---|
| 1632 | customMatch exact [list string equal] |
---|
| 1633 | set v [verbose] |
---|
| 1634 | proc string args {error {called [string] in caller namespace}} |
---|
| 1635 | } -body { |
---|
| 1636 | verbose {} |
---|
| 1637 | test tcltest-24.12.0 {} -body {format 1} -result 1 |
---|
| 1638 | } -cleanup { |
---|
| 1639 | rename string {} |
---|
| 1640 | verbose $v |
---|
| 1641 | customMatch exact $saveExactMatchScript |
---|
| 1642 | unset saveExactMatchScript |
---|
| 1643 | } -match exact -result {} -output {} |
---|
| 1644 | |
---|
| 1645 | test tcltest-24.13 { |
---|
| 1646 | test: -match exact failure |
---|
| 1647 | } -setup { |
---|
| 1648 | set saveExactMatchScript $::tcltest::CustomMatch(exact) |
---|
| 1649 | customMatch exact [list string equal] |
---|
| 1650 | set v [verbose] |
---|
| 1651 | set fail $::tcltest::currentFailure |
---|
| 1652 | } -body { |
---|
| 1653 | verbose {} |
---|
| 1654 | test tcltest-24.13.0 {} -body {format 1} -result 0 |
---|
| 1655 | } -cleanup { |
---|
| 1656 | set ::tcltest::currentFailure $fail |
---|
| 1657 | verbose $v |
---|
| 1658 | customMatch exact $saveExactMatchScript |
---|
| 1659 | unset saveExactMatchScript |
---|
| 1660 | } -match glob -result {} -output {*FAILED*Result was: |
---|
| 1661 | 1*(exact matching): |
---|
| 1662 | 0*} |
---|
| 1663 | |
---|
| 1664 | test tcltest-24.14 { |
---|
| 1665 | test: -match glob |
---|
| 1666 | } -body { |
---|
| 1667 | set result {A B C} |
---|
| 1668 | } -match glob -result {A B*} |
---|
| 1669 | |
---|
| 1670 | test tcltest-24.15 { |
---|
| 1671 | test: -match glob failure |
---|
| 1672 | } -setup { |
---|
| 1673 | set v [verbose] |
---|
| 1674 | set fail $::tcltest::currentFailure |
---|
| 1675 | } -body { |
---|
| 1676 | verbose {} |
---|
| 1677 | test tcltest-24.15.0 {} -match glob -body {format {A B C}} \ |
---|
| 1678 | -result {A B* } |
---|
| 1679 | } -cleanup { |
---|
| 1680 | set ::tcltest::currentFailure $fail |
---|
| 1681 | verbose $v |
---|
| 1682 | } -match glob -result {} -output {*FAILED*Result was: |
---|
| 1683 | *(glob matching): |
---|
| 1684 | *} |
---|
| 1685 | |
---|
| 1686 | test tcltest-24.16 { |
---|
| 1687 | test: -match regexp |
---|
| 1688 | } -body { |
---|
| 1689 | set result {A B C} |
---|
| 1690 | } -match regexp -result {A B.*} |
---|
| 1691 | |
---|
| 1692 | test tcltest-24.17 { |
---|
| 1693 | test: -match regexp failure |
---|
| 1694 | } -setup { |
---|
| 1695 | set fail $::tcltest::currentFailure |
---|
| 1696 | set v [verbose] |
---|
| 1697 | } -body { |
---|
| 1698 | verbose {} |
---|
| 1699 | test tcltest-24.17.0 {} -match regexp -body {format {A B C}} \ |
---|
| 1700 | -result {A B.* X} |
---|
| 1701 | } -cleanup { |
---|
| 1702 | set ::tcltest::currentFailure $fail |
---|
| 1703 | verbose $v |
---|
| 1704 | } -match glob -result {} -output {*FAILED*Result was: |
---|
| 1705 | *(regexp matching): |
---|
| 1706 | *} |
---|
| 1707 | |
---|
| 1708 | test tcltest-24.18 { |
---|
| 1709 | test: -match custom forget namespace qualification |
---|
| 1710 | } -setup { |
---|
| 1711 | set fail $::tcltest::currentFailure |
---|
| 1712 | set v [verbose] |
---|
| 1713 | customMatch negative matchNegative |
---|
| 1714 | } -body { |
---|
| 1715 | verbose {} |
---|
| 1716 | test tcltest-24.18.0 {} -match negative -body {format {A B C}} \ |
---|
| 1717 | -result {A B X} |
---|
| 1718 | } -cleanup { |
---|
| 1719 | set ::tcltest::currentFailure $fail |
---|
| 1720 | verbose $v |
---|
| 1721 | } -match glob -result {} -output {*FAILED*Error testing result:*} |
---|
| 1722 | |
---|
| 1723 | test tcltest-24.19 { |
---|
| 1724 | test: -match custom |
---|
| 1725 | } -setup { |
---|
| 1726 | set v [verbose] |
---|
| 1727 | customMatch negative [namespace code matchNegative] |
---|
| 1728 | } -body { |
---|
| 1729 | verbose {} |
---|
| 1730 | test tcltest-24.19.0 {} -match negative -body {format {A B C}} \ |
---|
| 1731 | -result {A B X} |
---|
| 1732 | } -cleanup { |
---|
| 1733 | verbose $v |
---|
| 1734 | } -match exact -result {} -output {} |
---|
| 1735 | |
---|
| 1736 | test tcltest-24.20 { |
---|
| 1737 | test: -match custom failure |
---|
| 1738 | } -setup { |
---|
| 1739 | set fail $::tcltest::currentFailure |
---|
| 1740 | set v [verbose] |
---|
| 1741 | customMatch negative [namespace code matchNegative] |
---|
| 1742 | } -body { |
---|
| 1743 | verbose {} |
---|
| 1744 | test tcltest-24.20.0 {} -match negative -body {format {A B C}} \ |
---|
| 1745 | -result {A B C} |
---|
| 1746 | } -cleanup { |
---|
| 1747 | set ::tcltest::currentFailure $fail |
---|
| 1748 | verbose $v |
---|
| 1749 | } -match glob -result {} -output {*FAILED*Result was: |
---|
| 1750 | *(negative matching): |
---|
| 1751 | *} |
---|
| 1752 | |
---|
| 1753 | test tcltest-25.1 { |
---|
| 1754 | constraint of setup/cleanup (Bug 589859) |
---|
| 1755 | } -setup { |
---|
| 1756 | set foo 0 |
---|
| 1757 | } -body { |
---|
| 1758 | # Buggy tcltest will generate result of 2 |
---|
| 1759 | test tcltest-25.1.0 {} -constraints knownBug -setup { |
---|
| 1760 | incr foo |
---|
| 1761 | } -body { |
---|
| 1762 | incr foo |
---|
| 1763 | } -cleanup { |
---|
| 1764 | incr foo |
---|
| 1765 | } -match glob -result * |
---|
| 1766 | set foo |
---|
| 1767 | } -cleanup { |
---|
| 1768 | unset foo |
---|
| 1769 | } -result 0 |
---|
| 1770 | |
---|
| 1771 | test tcltest-25.2 { |
---|
| 1772 | puts -nonewline (Bug 612786) |
---|
| 1773 | } -body { |
---|
| 1774 | puts -nonewline stdout bla |
---|
| 1775 | puts -nonewline stdout bla |
---|
| 1776 | } -output {blabla} |
---|
| 1777 | |
---|
| 1778 | test tcltest-25.3 { |
---|
| 1779 | reported return code (Bug 611922) |
---|
| 1780 | } -setup { |
---|
| 1781 | set fail $::tcltest::currentFailure |
---|
| 1782 | set v [verbose] |
---|
| 1783 | } -body { |
---|
| 1784 | verbose {} |
---|
| 1785 | test tcltest-25.3.0 {} -body { |
---|
| 1786 | error foo |
---|
| 1787 | } |
---|
| 1788 | } -cleanup { |
---|
| 1789 | set ::tcltest::currentFailure $fail |
---|
| 1790 | verbose $v |
---|
| 1791 | } -match glob -output {*generated error; Return code was: 1*} |
---|
| 1792 | |
---|
| 1793 | test tcltest-26.1 {Bug/RFE 1017151} -setup { |
---|
| 1794 | makeFile { |
---|
| 1795 | package require tcltest |
---|
| 1796 | set ::errorInfo "Should never see this" |
---|
| 1797 | tcltest::test tcltest-26.1.0 { |
---|
| 1798 | no errorInfo when only return code mismatch |
---|
| 1799 | } -body { |
---|
| 1800 | set x 1 |
---|
| 1801 | } -returnCodes error -result 1 |
---|
| 1802 | tcltest::cleanupTests |
---|
| 1803 | } test.tcl |
---|
| 1804 | } -body { |
---|
| 1805 | slave msg [file join [temporaryDirectory] test.tcl] |
---|
| 1806 | return $msg |
---|
| 1807 | } -cleanup { |
---|
| 1808 | removeFile test.tcl |
---|
| 1809 | } -match glob -result {* |
---|
| 1810 | ---- Return code should have been one of: 1 |
---|
| 1811 | ==== tcltest-26.1.0 FAILED*} |
---|
| 1812 | |
---|
| 1813 | test tcltest-26.2 {Bug/RFE 1017151} -setup { |
---|
| 1814 | makeFile { |
---|
| 1815 | package require tcltest |
---|
| 1816 | set ::errorInfo "Should never see this" |
---|
| 1817 | tcltest::test tcltest-26.2.0 {do not mask body errorInfo} -body { |
---|
| 1818 | error "body error" |
---|
| 1819 | } -cleanup { |
---|
| 1820 | error "cleanup error" |
---|
| 1821 | } -result 1 |
---|
| 1822 | tcltest::cleanupTests |
---|
| 1823 | } test.tcl |
---|
| 1824 | } -body { |
---|
| 1825 | slave msg [file join [temporaryDirectory] test.tcl] |
---|
| 1826 | return $msg |
---|
| 1827 | } -cleanup { |
---|
| 1828 | removeFile test.tcl |
---|
| 1829 | } -match glob -result {* |
---|
| 1830 | ---- errorInfo: body error |
---|
| 1831 | * |
---|
| 1832 | ---- errorInfo(cleanup): cleanup error*} |
---|
| 1833 | |
---|
| 1834 | cleanupTests |
---|
| 1835 | } |
---|
| 1836 | |
---|
| 1837 | namespace delete ::tcltest::test |
---|
| 1838 | return |
---|