diff options
Diffstat (limited to 'tests/tcltest.test')
| -rw-r--r-- | tests/tcltest.test | 375 |
1 files changed, 179 insertions, 196 deletions
diff --git a/tests/tcltest.test b/tests/tcltest.test index 114ce30..ce8d617 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -2,8 +2,8 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright © 1998-1999 Scriptics Corporation. -# Copyright © 2000 Ajuba Solutions +# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # Note that there are several places where the value of @@ -13,24 +13,21 @@ # testing to run the test itself. Ditto on things like [verbose]. # # It would be better to have the -body of the tests run the tcltest -# commands in a child interp so the [test] being tested would not +# commands in a slave interp so the [test] being tested would not # interfere with the [test] doing the testing. # -if {"::tcltest" ni [namespace children]} { - package require tcltest 2.5 - namespace import -force ::tcltest::* +if {[catch {package require tcltest 2.1}]} { + puts stderr "Skipping tests in [info script]. tcltest 2.1 required." + return } -# File permissions broken on wsl without some "exotic" wsl configuration -testConstraint notWsl [expr {[llength [array names ::env *WSL*]] == 0}] - namespace eval ::tcltest::test { namespace import ::tcltest::* makeFile { - package require tcltest 2.5 + package require tcltest namespace import ::tcltest::test test a-1.0 {test a} { list 0 @@ -49,7 +46,6 @@ makeFile { cd [temporaryDirectory] testConstraint exec [llength [info commands exec]] - # test -help # Child processes because -help [exit]s. test tcltest-1.1 {tcltest -help} {exec} { @@ -66,11 +62,11 @@ test tcltest-1.3 {tcltest -h} {exec} { } {1 0} # -verbose, implicit & explicit testing of [verbose] -proc child {msgVar args} { +proc slave {msgVar args} { upvar 1 $msgVar msg interp create [namespace current]::i - # Fake the child interp into dumping output to a file + # Fake the slave interp into dumping output to a file i eval {namespace eval ::tcltest {}} i eval "set tcltest::outputChannel\ \[[list open [set of [makeFile {} output]] w]]" @@ -101,54 +97,54 @@ proc child {msgVar args} { } return $code } -test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrWin} { - set result [child msg test.tcl] +test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} { + set result [slave msg test.tcl] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 0 0 1} -test tcltest-2.1 {tcltest -verbose 'b'} {unixOrWin} { - set result [child msg test.tcl -verbose 'b'] +test tcltest-2.1 {tcltest -verbose 'b'} {unixOrPc} { + set result [slave msg test.tcl -verbose 'b'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 0 0 1} -test tcltest-2.2 {tcltest -verbose 'p'} {unixOrWin} { - set result [child msg test.tcl -verbose 'p'] +test tcltest-2.2 {tcltest -verbose 'p'} {unixOrPc} { + set result [slave msg test.tcl -verbose 'p'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 1 0 1} -test tcltest-2.3 {tcltest -verbose 's'} {unixOrWin} { - set result [child msg test.tcl -verbose 's'] +test tcltest-2.3 {tcltest -verbose 's'} {unixOrPc} { + set result [slave msg test.tcl -verbose 's'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 0 1 1} -test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrWin} { - set result [child msg test.tcl -verbose 'ps'] +test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrPc} { + set result [slave msg test.tcl -verbose 'ps'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 0 1 1 1} -test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrWin} { - set result [child msg test.tcl -verbose 'psb'] +test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrPc} { + set result [slave msg test.tcl -verbose 'psb'] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 1 1 1} -test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrWin} { - set result [child msg test.tcl -verbose "pass skip body"] +test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} { + set result [slave msg test.tcl -verbose "pass skip body"] list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \ [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 1 1 1} test tcltest-2.6 {tcltest -verbose 't'} { - -constraints {unixOrWin} + -constraints {unixOrPc} -body { - set result [child msg test.tcl -verbose 't'] + set result [slave msg test.tcl -verbose 't'] list $result $msg } -result {^0 .*a-1.0 start.*b-1.0 start} @@ -156,9 +152,9 @@ test tcltest-2.6 {tcltest -verbose 't'} { } test tcltest-2.6a {tcltest -verbose 'start'} { - -constraints {unixOrWin} + -constraints {unixOrPc} -body { - set result [child msg test.tcl -verbose start] + set result [slave msg test.tcl -verbose start] list $result $msg } -result {^0 .*a-1.0 start.*b-1.0 start} @@ -173,38 +169,38 @@ test tcltest-2.7 {tcltest::verbose} { verbose foo set newVerbosity [verbose] verbose $oldVerbosity - list $currentVerbosity $newVerbosity + list $currentVerbosity $newVerbosity } -result {body {}} } test tcltest-2.8 {tcltest -verbose 'error'} { - -constraints {unixOrWin} + -constraints {unixOrPc} -body { - set result [child msg test.tcl -verbose error] + set result [slave msg test.tcl -verbose error] list $result $msg } -result {errorInfo: foo.*errorCode: 9} -match regexp } # -match, [match] -test tcltest-3.1 {tcltest -match 'a*'} {unixOrWin} { - set result [child msg test.tcl -match a* -verbose 'ps'] +test tcltest-3.1 {tcltest -match 'a*'} {unixOrPc} { + set result [slave msg test.tcl -match a* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 1 0 0 1} -test tcltest-3.2 {tcltest -match 'b*'} {unixOrWin} { - set result [child msg test.tcl -match b* -verbose 'ps'] +test tcltest-3.2 {tcltest -match 'b*'} {unixOrPc} { + set result [slave msg test.tcl -match b* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg] } {0 0 1 0 1} -test tcltest-3.3 {tcltest -match 'c*'} {unixOrWin} { - set result [child msg test.tcl -match c* -verbose 'ps'] +test tcltest-3.3 {tcltest -match 'c*'} {unixOrPc} { + set result [slave msg test.tcl -match c* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg] } {0 0 0 1 1} -test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrWin} { - set result [child msg test.tcl -match {a* b*} -verbose 'ps'] +test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrPc} { + set result [slave msg test.tcl -match {a* b*} -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg] } {0 1 1 0 1} @@ -221,30 +217,30 @@ test tcltest-3.5 {tcltest::match} { } -result {foo bar} } - + # -skip, [skip] -test tcltest-4.1 {tcltest -skip 'a*'} {unixOrWin} { - set result [child msg test.tcl -skip a* -verbose 'ps'] +test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} { + set result [slave msg test.tcl -skip a* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg] } {0 0 1 1 1} -test tcltest-4.2 {tcltest -skip 'b*'} {unixOrWin} { - set result [child msg test.tcl -skip b* -verbose 'ps'] +test tcltest-4.2 {tcltest -skip 'b*'} {unixOrPc} { + set result [slave msg test.tcl -skip b* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg] } {0 1 0 1 1} -test tcltest-4.3 {tcltest -skip 'c*'} {unixOrWin} { - set result [child msg test.tcl -skip c* -verbose 'ps'] +test tcltest-4.3 {tcltest -skip 'c*'} {unixOrPc} { + set result [slave msg test.tcl -skip c* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg] } {0 1 1 0 1} -test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrWin} { - set result [child msg test.tcl -skip {a* b*} -verbose 'ps'] +test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrPc} { + set result [slave msg test.tcl -skip {a* b*} -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg] } {0 0 0 1 1} -test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrWin} { - set result [child msg test.tcl -match {a* b*} -skip b* -verbose 'ps'] +test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrPc} { + set result [slave msg test.tcl -match {a* b*} -skip b* -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 1 0 0 1} @@ -264,13 +260,13 @@ test tcltest-4.6 {tcltest::skip} { # -constraints, -limitconstraints, [testConstraint], # $constraintsSpecified, [limitConstraints] -test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrWin} { - set result [child msg test.tcl -constraints knownBug -verbose 'ps'] +test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} { + set result [slave msg test.tcl -constraints knownBug -verbose 'ps'] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg] } {0 1 1 1 1} -test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrWin} { - set result [child msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1] +test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrPc} { + set result [slave msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1] list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \ [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg] } {0 0 0 1 1} @@ -303,13 +299,13 @@ test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)} { # -result {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}} # -cleanup { # set ::tcltest::constraintsSpecified $constraintlist -# unset ::tcltest::testConstraints(tcltestFakeConstraint1) -# unset ::tcltest::testConstraints(tcltestFakeConstraint2) +# unset ::tcltest::testConstraints(tcltestFakeConstraint1) +# unset ::tcltest::testConstraints(tcltestFakeConstraint2) # } #} test tcltest-5.5 {InitConstraints: list of built-in constraints} \ - -constraints {!singleTestInterp notWsl} \ + -constraints {!singleTestInterp} \ -setup {tcltest::InitConstraints} \ -body { lsort [array names ::tcltest::testConstraints] } \ -result [lsort { @@ -343,7 +339,7 @@ test tcltest-5.5 {InitConstraints: list of built-in constraints} \ # -outfile, -errfile, [outputChannel], [outputFile], [errorChannel], [errorFile] set printerror [makeFile { - package require tcltest 2.5 + package require tcltest namespace import ::tcltest::* puts [outputChannel] "a test" ::tcltest::PrintError "a really short string" @@ -352,36 +348,36 @@ set printerror [makeFile { ::tcltest::PrintError "a really really long string containing a \ \"Path/that/is/really/long/and/contains/no/spaces\"" ::tcltest::PrintError "a really really long string containing a \ - \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\"" + \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\"" ::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\"" exit } printerror.tcl] test tcltest-6.1 {tcltest -outfile, -errfile defaults} { - -constraints unixOrWin + -constraints unixOrPc -body { - child msg $printerror + slave msg $printerror return $msg } -result {a test.*a really} -match regexp } -test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrWin unixExecs} { - child msg $printerror -outfile a.tmp +test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} { + slave msg $printerror -outfile a.tmp set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" a.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ - $result1 $result2 [file exists a.tmp] [file delete a.tmp] + $result1 $result2 [file exists a.tmp] [file delete a.tmp] } {0 1 0 1 1 {}} -test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrWin unixExecs} { - child msg $printerror -errfile a.tmp +test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} { + slave msg $printerror -errfile a.tmp set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" a.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ $result1 $result2 [file exists a.tmp] [file delete a.tmp] } {1 0 1 0 1 {}} -test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrWin unixExecs} { - child msg $printerror -outfile a.tmp -errfile b.tmp +test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrPc unixExecs} { + slave msg $printerror -outfile a.tmp -errfile b.tmp set result1 [catch {exec grep "a test" a.tmp}] set result2 [catch {exec grep "a really" b.tmp}] list [regexp "a test" $msg] [regexp "a really" $msg] \ @@ -417,7 +413,7 @@ test tcltest-6.6 {tcltest::errorFile (implicit errorChannel)} { set f2 [errorFile $ef] set f3 [errorChannel] set f4 [errorFile] - subst {$f0;$f1;$f2;$f3;$f4} + subst {$f0;$f1;$f2;$f3;$f4} } -result {stderr;stderr;.*efile;file[0-9a-f]+;.*efile} -match regexp @@ -453,7 +449,7 @@ test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} { set f2 [outputFile $ef] set f3 [outputChannel] set f4 [outputFile] - subst {$f0;$f1;$f2;$f3;$f4} + subst {$f0;$f1;$f2;$f3;$f4} } -result {stdout;stdout;.*efile;file[0-9a-f]+;.*efile} -match regexp @@ -466,26 +462,26 @@ test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} { # -debug, [debug] # Must use child processes to test -debug because it always writes # messages to stdout, and we have no way to capture stdout of a -# child interp -test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrWin} { +# slave interp +test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrPc} { catch {exec [interpreter] test.tcl -debug 0} msg regexp "Flags passed into tcltest" $msg } {0} -test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrWin} { +test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrPc} { catch {exec [interpreter] test.tcl -debug 1 -skip b*} msg list [regexp userSpecifiedSkip $msg] \ [regexp "Flags passed into tcltest" $msg] } {1 0} -test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrWin} { +test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrPc} { catch {exec [interpreter] test.tcl -debug 1 -match b*} msg list [regexp userSpecifiedNonMatch $msg] \ [regexp "Flags passed into tcltest" $msg] } {1 0} -test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrWin} { +test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrPc} { catch {exec [interpreter] test.tcl -debug 2} msg list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg] } {1 0} -test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrWin} { +test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrPc} { catch {exec [interpreter] test.tcl -debug 3} msg list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg] } {1 1} @@ -513,7 +509,7 @@ removeFile test.tcl # directory tests set a [makeFile { - package require tcltest 2.5 + package require tcltest tcltest::makeFile {} a.tmp puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]" exit @@ -525,43 +521,42 @@ set normaldirectory [makeDirectory normaldirectory] normalizePath normaldirectory # -tmpdir, [temporaryDirectory] -test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrWin -setup { +test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrPc -setup { file delete -force thisdirectorydoesnotexist } -body { - child msg $a -tmpdir thisdirectorydoesnotexist + slave msg $a -tmpdir thisdirectorydoesnotexist file exists [file join thisdirectorydoesnotexist a.tmp] } -cleanup { file delete -force thisdirectorydoesnotexist } -result 1 test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} { - -constraints unixOrWin + -constraints unixOrPc -body { - child msg $a -tmpdir $tdiaf + slave msg $a -tmpdir $tdiaf return $msg } -result {*not a directory*} -match glob } -# Test non-writable directories, non-readable directories with directory flags +# Test non-writeable directories, non-readable directories with directory flags set notReadableDir [file join [temporaryDirectory] notreadable] -set notWritableDir [file join [temporaryDirectory] notwritable] +set notWriteableDir [file join [temporaryDirectory] notwriteable] makeDirectory notreadable -makeDirectory notwritable +makeDirectory notwriteable switch -- $::tcl_platform(platform) { unix { - file attributes $notReadableDir -permissions 0o333 - file attributes $notWritableDir -permissions 0o555 + file attributes $notReadableDir -permissions 00333 + file attributes $notWriteableDir -permissions 00555 } default { - # note in FAT/NTFS we won't be able to protect directory with read-only attribute... - catch {file attributes $notWritableDir -readonly 1} - catch {testchmod 0o444 $notWritableDir} + catch {file attributes $notWriteableDir -readonly 1} + catch {testchmod 000 $notWriteableDir} } } test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} { - -constraints {unix notRoot notWsl} + -constraints {unix notRoot} -body { - child msg $a -tmpdir $notReadableDir + slave msg $a -tmpdir $notReadableDir return $msg } -result {*not readable*} @@ -570,23 +565,22 @@ test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} { # This constraint doesn't go at the top of the file so that it doesn't # interfere with tcltest-5.5 testConstraint notFAT [expr { - ![regexp {^(FAT\d*|NTFS)$} [lindex [file system $notWritableDir] 1]] - || $::tcl_platform(platform) eq "unix" || [llength [info commands testchmod]] + ![string match "FAT*" [lindex [file system $notWriteableDir] 1]] }] -# FAT/NTFS permissions are fairly hopeless; ignore this test if that FS is used -test tcltest-8.4 {tcltest a.tcl -tmpdir notWritableDir} { - -constraints {unixOrWin notRoot notFAT notWsl} +# FAT permissions are fairly hopeless; ignore this test if that FS is used +test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} { + -constraints {unixOrPc notRoot notFAT} -body { - child msg $a -tmpdir $notWritableDir + slave msg $a -tmpdir $notWriteableDir return $msg } - -result {*not writable*} + -result {*not writeable*} -match glob } test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} { - -constraints unixOrWin + -constraints unixOrPc -body { - child msg $a -tmpdir $normaldirectory + slave msg $a -tmpdir $normaldirectory # The join is necessary because the message can be split on multiple # lines file exists [file join $normaldirectory a.tmp] @@ -627,39 +621,39 @@ test tcltest-8.6a {temporaryDirectory - test format 2} -setup { cd [temporaryDirectory] # -testdir, [testsDirectory] test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} { - -constraints unixOrWin + -constraints unixOrPc -setup { file delete -force thisdirectorydoesnotexist } -body { - child msg $a -testdir thisdirectorydoesnotexist + slave msg $a -testdir thisdirectorydoesnotexist return $msg } -match glob -result {*does not exist*} } test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} { - -constraints unixOrWin + -constraints unixOrPc -body { - child msg $a -testdir $tdiaf + slave msg $a -testdir $tdiaf return $msg } -match glob -result {*not a directory*} } test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} { - -constraints {unix notRoot notWsl} + -constraints {unix notRoot} -body { - child msg $a -testdir $notReadableDir + slave msg $a -testdir $notReadableDir return $msg } -match glob -result {*not readable*} } test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} { - -constraints unixOrWin + -constraints unixOrPc -body { - child msg $a -testdir $normaldirectory + slave msg $a -testdir $normaldirectory # The join is necessary because the message can be split on multiple # lines list [string first "testdir: $normaldirectory" [join $msg]] \ @@ -719,36 +713,36 @@ test tcltest-8.60 {::workingDirectory} { switch -- $::tcl_platform(platform) { unix { - file attributes $notReadableDir -permissions 0o777 - file attributes $notWritableDir -permissions 0o777 + file attributes $notReadableDir -permissions 777 + file attributes $notWriteableDir -permissions 777 } default { - catch {testchmod 0o777 $notWritableDir} - catch {file attributes $notWritableDir -readonly 0} + catch {testchmod 777 $notWriteableDir} + catch {file attributes $notWriteableDir -readonly 0} } } -file delete -force -- $notReadableDir $notWritableDir +file delete -force -- $notReadableDir $notWriteableDir removeFile a.tcl removeFile thisdirectoryisafile removeDirectory normaldirectory # -file, -notfile, [matchFiles], [skipFiles] -test tcltest-9.1 {-file d*.tcl} -constraints {unixOrWin} -setup { +test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup { set old [testsDirectory] testsDirectory [file dirname [info script]] } -body { - child msg [file join [testsDirectory] all.tcl] -file d*.test + slave msg [file join [testsDirectory] all.tcl] -file d*.test return $msg } -cleanup { testsDirectory $old } -match regexp -result {dstring\.test} -test tcltest-9.2 {-file d*.tcl} -constraints {unixOrWin} -setup { +test tcltest-9.2 {-file d*.tcl} -constraints {unixOrPc} -setup { set old [testsDirectory] testsDirectory [file dirname [info script]] } -body { - child msg [file join [testsDirectory] all.tcl] \ + slave msg [file join [testsDirectory] all.tcl] \ -file d*.test -notfile dstring* regexp {dstring\.test} $msg } -cleanup { @@ -764,7 +758,7 @@ test tcltest-9.3 {matchFiles} { set new [matchFiles] matchFiles $old list $current $new - } + } -result {foo bar} } @@ -777,7 +771,7 @@ test tcltest-9.4 {skipFiles} { set new [skipFiles] skipFiles $old list $current $new - } + } -result {foo bar} } @@ -787,7 +781,7 @@ test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup { makeFile {} fee $d file copy [file join [file dirname [info script]] all.tcl] $d } -body { - child msg [file join [temporaryDirectory] all.tcl] -file f* + slave msg [file join [temporaryDirectory] all.tcl] -file f* regexp {exiting with errors:} $msg } -cleanup { file delete [file join $d all.tcl] @@ -798,7 +792,7 @@ test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup { # -preservecore, [preserveCore] set mc [makeFile { - package require tcltest 2.5 + package require tcltest namespace import ::tcltest::test test makecore {make a core file} { set f [open core w] @@ -809,24 +803,24 @@ set mc [makeFile { } makecore.tcl] cd [temporaryDirectory] -test tcltest-10.1 {-preservecore 0} {unixOrWin} { - child msg $mc -preservecore 0 +test tcltest-10.1 {-preservecore 0} {unixOrPc} { + slave msg $mc -preservecore 0 file delete core regexp "Core file produced" $msg } {0} -test tcltest-10.2 {-preservecore 1} {unixOrWin} { - child msg $mc -preservecore 1 +test tcltest-10.2 {-preservecore 1} {unixOrPc} { + slave msg $mc -preservecore 1 file delete core regexp "Core file produced" $msg } {1} -test tcltest-10.3 {-preservecore 2} {unixOrWin} { - child msg $mc -preservecore 2 +test tcltest-10.3 {-preservecore 2} {unixOrPc} { + slave msg $mc -preservecore 2 file delete core list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \ [regexp "core-" $msg] [file delete core-makecore] } {1 1 1 {}} -test tcltest-10.4 {-preservecore 3} {unixOrWin} { - child msg $mc -preservecore 3 +test tcltest-10.4 {-preservecore 3} {unixOrPc} { + slave msg $mc -preservecore 3 file delete core list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \ [regexp "core-" $msg] [file delete core-makecore] @@ -849,20 +843,20 @@ removeFile makecore.tcl # -load, -loadfile, [loadScript], [loadFile] set contents { - package require tcltest 2.5 + package require tcltest namespace import tcltest::* puts [outputChannel] $::tcltest::loadScript exit } set loadfile [makeFile $contents load.tcl] -test tcltest-12.1 {-load xxx} {unixOrWin} { - child msg $loadfile -load xxx +test tcltest-12.1 {-load xxx} {unixOrPc} { + slave msg $loadfile -load xxx return $msg } {xxx} # Using child process because of -debug usage. -test tcltest-12.2 {-loadfile load.tcl} {unixOrWin} { +test tcltest-12.2 {-loadfile load.tcl} {unixOrPc} { catch {exec [interpreter] $loadfile -debug 2 -loadfile $loadfile} msg list \ [regexp {tcltest} [join [list $msg] [split $msg \n]]] \ @@ -911,9 +905,7 @@ removeFile load.tcl # [interpreter] test tcltest-13.1 {interpreter} { - -constraints notValgrind -setup { - #to do: Why is $::tcltest::tcltest being saved and restored here? set old $::tcltest::tcltest set ::tcltest::tcltest tcltest } @@ -925,11 +917,6 @@ test tcltest-13.1 {interpreter} { } -result {tcltest tclsh tclsh} -cleanup { - # writing ::tcltest::tcltest triggers a trace that sets up the stdio - # constraint, which involves a call to [exec] that might fail after - # "fork" and before "exec", in which case the forked process will not - # have a chance to clean itself up before exiting, which causes - # valgrind to issue numerous "still reachable" reports. set ::tcltest::tcltest $old } } @@ -945,7 +932,7 @@ makeFile { } single2.test $spd set allfile [makeFile { - package require tcltest 2.5 + package require tcltest namespace import tcltest::* testsDirectory [file join [temporaryDirectory] singleprocdir] runAllTests @@ -953,9 +940,9 @@ set allfile [makeFile { cd [workingDirectory] test tcltest-14.1 {-singleproc - single process} { - -constraints {unixOrWin} + -constraints {unixOrPc} -body { - child msg $allfile -singleproc 0 -tmpdir [temporaryDirectory] + slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory] return $msg } -result {Test file error: can't unset .foo.: no such variable} @@ -963,9 +950,9 @@ test tcltest-14.1 {-singleproc - single process} { } test tcltest-14.2 {-singleproc - multiple process} { - -constraints {unixOrWin} + -constraints {unixOrPc} -body { - child msg $allfile -singleproc 1 -tmpdir [temporaryDirectory] + slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory] return $msg } -result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0} @@ -1002,34 +989,34 @@ set dtd1 [makeDirectory dirtestdir2.1 $dtd] set dtd2 [makeDirectory dirtestdir2.2 $dtd] set dtd3 [makeDirectory dirtestdir2.3 $dtd] makeFile { - package require tcltest 2.5 + package require tcltest namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir] runAllTests } all.tcl $dtd makeFile { - package require tcltest 2.5 + package require tcltest namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.1] runAllTests } all.tcl $dtd1 makeFile { - package require tcltest 2.5 + package require tcltest namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.2] runAllTests } all.tcl $dtd2 makeFile { - package require tcltest 2.5 + package require tcltest namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3] runAllTests } all.tcl $dtd3 test tcltest-15.1 {basic directory walking} { - -constraints {unixOrWin} + -constraints {unixOrPc} -body { - if {[child msg \ + if {[slave msg \ [file join $dtd all.tcl] \ -tmpdir [temporaryDirectory]] == 1} { error $msg @@ -1041,9 +1028,9 @@ test tcltest-15.1 {basic directory walking} { } test tcltest-15.2 {-asidefromdir} { - -constraints {unixOrWin} + -constraints {unixOrPc} -body { - if {[child msg \ + if {[slave msg \ [file join $dtd all.tcl] \ -asidefromdir dirtestdir2.3 \ -tmpdir [temporaryDirectory]] == 1} { @@ -1059,9 +1046,9 @@ Error: No test files remain after applying your match and skip patterns!$} } test tcltest-15.3 {-relateddir, non-existent dir} { - -constraints {unixOrWin} + -constraints {unixOrPc} -body { - if {[child msg \ + if {[slave msg \ [file join $dtd all.tcl] \ -relateddir [file join [temporaryDirectory] dirtestdir0] \ -tmpdir [temporaryDirectory]] == 1} { @@ -1074,9 +1061,9 @@ test tcltest-15.3 {-relateddir, non-existent dir} { } test tcltest-15.4 {-relateddir, subdir} { - -constraints {unixOrWin} + -constraints {unixOrPc} -body { - if {[child msg \ + if {[slave msg \ [file join $dtd all.tcl] \ -relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} { error $msg @@ -1087,9 +1074,9 @@ test tcltest-15.4 {-relateddir, subdir} { -result {Tests located in:.*dirtestdir2.[^23]} } test tcltest-15.5 {-relateddir, -asidefromdir} { - -constraints {unixOrWin} + -constraints {unixOrPc} -body { - if {[child msg \ + if {[slave msg \ [file join $dtd all.tcl] \ -relateddir "dirtestdir2.1 dirtestdir2.2" \ -asidefromdir dirtestdir2.2 \ @@ -1150,25 +1137,25 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { # set this to { } instead of just {} to get around quirk in # Windows env handling that removes empty elements from env array. set ::env(TCLTEST_OPTIONS) { } - interp create child1 - child1 eval [list set argv {-debug 2}] - child1 alias puts puts - interp create child2 - child2 alias puts puts + interp create slave1 + slave1 eval [list set argv {-debug 2}] + slave1 alias puts puts + interp create slave2 + slave2 alias puts puts } -cleanup { - interp delete child2 - interp delete child1 + interp delete slave2 + interp delete slave1 if {$oldoptions eq "none"} { - unset ::env(TCLTEST_OPTIONS) + unset ::env(TCLTEST_OPTIONS) } else { set ::env(TCLTEST_OPTIONS) $oldoptions } } -body { - child1 eval [package ifneeded tcltest [package provide tcltest]] - child1 eval tcltest::debug + slave1 eval [package ifneeded tcltest [package provide tcltest]] + slave1 eval tcltest::debug set ::env(TCLTEST_OPTIONS) "-debug 3" - child2 eval [package ifneeded tcltest [package provide tcltest]] - child2 eval tcltest::debug + slave2 eval [package ifneeded tcltest [package provide tcltest]] + slave2 eval tcltest::debug } -result {^3$} -match regexp -output\ {tcltest::debug\s+= 2.*tcltest::debug\s+= 3} @@ -1176,8 +1163,8 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { cd [temporaryDirectory] # PrintError -test tcltest-20.1 {PrintError} {unixOrWin} { - set result [child msg $printerror] +test tcltest-20.1 {PrintError} {unixOrPc} { + set result [slave msg $printerror] list $result [regexp "Error: a really short string" $msg] \ [regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \ [regexp " \"Really" $msg] [regexp Problem $msg] @@ -1210,7 +1197,7 @@ test tcltest-21.2 {force a test command failure} { } {1} } -returnCodes 1 - -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } test tcltest-21.3 {test command with setup} { @@ -1273,7 +1260,7 @@ test tcltest-21.6 {test command - setup occurs before cleanup & before script} { } set foo 1 set expected 2 - } + } -body { incr foo set foo @@ -1303,7 +1290,7 @@ test tcltest-21.7 {test command - bad flag} { } } -returnCodes 1 - -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } # alternate test command format (these are the same as 21.1-21.6, with the @@ -1323,7 +1310,7 @@ test tcltest-21.8 {force a test command failure} \ } \ -returnCodes 1 \ -cleanup {set ::tcltest::currentFailure $fail} \ - -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} test tcltest-21.9 {test command with setup} \ -setup {set foo 1} \ @@ -1388,7 +1375,7 @@ test tcltest-21.12 { set atd [makeDirectory alltestdir] makeFile { - package require tcltest 2.5 + package require tcltest namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] alltestdir] runAllTests @@ -1400,7 +1387,7 @@ makeFile { error "throw an error" } error.test $atd makeFile { - package require tcltest 2.5 + package require tcltest namespace import -force tcltest::* test foo-1.1 {foo} { -body { return 1 } @@ -1410,9 +1397,9 @@ makeFile { } test.test $atd # Must use a child process because stdout/stderr parsing can't be -# duplicated in child interp. +# duplicated in slave interp. test tcltest-22.1 {runAllTests} { - -constraints {unixOrWin} + -constraints {unixOrPc} -body { exec [interpreter] \ [file join $atd all.tcl] \ @@ -1437,7 +1424,7 @@ test tcltest-23.1 {makeFile} { } -cleanup { file delete -force $mfdir \ - [file join [temporaryDirectory] t1.tmp] + [file join [temporaryDirectory] t1.tmp] } -result {1 1} } @@ -1447,7 +1434,7 @@ test tcltest-23.2 {removeFile} { file mkdir $mfdir makeFile {} t1.tmp makeFile {} et1.tmp $mfdir - if {![file exists [file join [temporaryDirectory] t1.tmp]] || \ + if {![file exists [file join [temporaryDirectory] t1.tmp]] || \ ![file exists [file join $mfdir et1.tmp]]} { error "file creation didn't work" } @@ -1460,7 +1447,7 @@ test tcltest-23.2 {removeFile} { } -cleanup { file delete -force $mfdir \ - [file join [temporaryDirectory] t1.tmp] + [file join [temporaryDirectory] t1.tmp] } -result {0 0} } @@ -1799,7 +1786,7 @@ test tcltest-25.3 { test tcltest-26.1 {Bug/RFE 1017151} -setup { makeFile { - package require tcltest 2.5 + package require tcltest set ::errorInfo "Should never see this" tcltest::test tcltest-26.1.0 { no errorInfo when only return code mismatch @@ -1809,7 +1796,7 @@ test tcltest-26.1 {Bug/RFE 1017151} -setup { tcltest::cleanupTests } test.tcl } -body { - child msg [file join [temporaryDirectory] test.tcl] + slave msg [file join [temporaryDirectory] test.tcl] return $msg } -cleanup { removeFile test.tcl @@ -1819,7 +1806,7 @@ test tcltest-26.1 {Bug/RFE 1017151} -setup { test tcltest-26.2 {Bug/RFE 1017151} -setup { makeFile { - package require tcltest 2.5 + package require tcltest set ::errorInfo "Should never see this" tcltest::test tcltest-26.2.0 {do not mask body errorInfo} -body { error "body error" @@ -1829,7 +1816,7 @@ test tcltest-26.2 {Bug/RFE 1017151} -setup { tcltest::cleanupTests } test.tcl } -body { - child msg [file join [temporaryDirectory] test.tcl] + slave msg [file join [temporaryDirectory] test.tcl] return $msg } -cleanup { removeFile test.tcl @@ -1837,13 +1824,9 @@ test tcltest-26.2 {Bug/RFE 1017151} -setup { ---- errorInfo: body error * ---- errorInfo(cleanup): cleanup error*} - + cleanupTests } namespace delete ::tcltest::test return - -# Local Variables: -# mode: tcl -# End: |