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