diff options
Diffstat (limited to 'tests/tcltest.test')
| -rw-r--r-- | tests/tcltest.test | 62 |
1 files changed, 38 insertions, 24 deletions
diff --git a/tests/tcltest.test b/tests/tcltest.test index ce8d617..ca720ee 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -46,6 +46,7 @@ makeFile { cd [temporaryDirectory] testConstraint exec [llength [info commands exec]] + # test -help # Child processes because -help [exit]s. test tcltest-1.1 {tcltest -help} {exec} { @@ -142,7 +143,7 @@ test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} { } {0 1 1 1 1} test tcltest-2.6 {tcltest -verbose 't'} { - -constraints {unixOrPc} + -constraints {unixOrPc} -body { set result [slave msg test.tcl -verbose 't'] list $result $msg @@ -152,7 +153,7 @@ test tcltest-2.6 {tcltest -verbose 't'} { } test tcltest-2.6a {tcltest -verbose 'start'} { - -constraints {unixOrPc} + -constraints {unixOrPc} -body { set result [slave msg test.tcl -verbose start] list $result $msg @@ -169,7 +170,7 @@ test tcltest-2.7 {tcltest::verbose} { verbose foo set newVerbosity [verbose] verbose $oldVerbosity - list $currentVerbosity $newVerbosity + list $currentVerbosity $newVerbosity } -result {body {}} } @@ -217,7 +218,7 @@ test tcltest-3.5 {tcltest::match} { } -result {foo bar} } - + # -skip, [skip] test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} { set result [slave msg test.tcl -skip a* -verbose 'ps'] @@ -299,8 +300,8 @@ 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) # } #} @@ -348,7 +349,7 @@ 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] @@ -367,7 +368,7 @@ test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} { 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} {unixOrPc unixExecs} { slave msg $printerror -errfile a.tmp @@ -413,7 +414,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 @@ -449,7 +450,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 @@ -549,8 +550,9 @@ switch -- $::tcl_platform(platform) { 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 $notWriteableDir -readonly 1} - catch {testchmod 000 $notWriteableDir} + catch {testchmod 0 $notWriteableDir} } } test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} { @@ -565,9 +567,10 @@ 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 { - ![string match "FAT*" [lindex [file system $notWriteableDir] 1]] + ![regexp {^(FAT\d*|NTFS)$} [lindex [file system $notWriteableDir] 1]] + || $::tcl_platform(platform) eq "unix" || [llength [info commands testchmod]] }] -# FAT permissions are fairly hopeless; ignore this test if that FS is used +# FAT/NTFS 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 { @@ -717,7 +720,7 @@ switch -- $::tcl_platform(platform) { file attributes $notWriteableDir -permissions 777 } default { - catch {testchmod 777 $notWriteableDir} + catch {testchmod 0o777 $notWriteableDir} catch {file attributes $notWriteableDir -readonly 0} } } @@ -758,7 +761,7 @@ test tcltest-9.3 {matchFiles} { set new [matchFiles] matchFiles $old list $current $new - } + } -result {foo bar} } @@ -771,7 +774,7 @@ test tcltest-9.4 {skipFiles} { set new [skipFiles] skipFiles $old list $current $new - } + } -result {foo bar} } @@ -905,7 +908,9 @@ 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 } @@ -917,6 +922,11 @@ 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 } } @@ -1146,7 +1156,7 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { interp delete slave2 interp delete slave1 if {$oldoptions eq "none"} { - unset ::env(TCLTEST_OPTIONS) + unset ::env(TCLTEST_OPTIONS) } else { set ::env(TCLTEST_OPTIONS) $oldoptions } @@ -1197,7 +1207,7 @@ test tcltest-21.2 {force a test command failure} { } {1} } -returnCodes 1 - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } test tcltest-21.3 {test command with setup} { @@ -1260,7 +1270,7 @@ test tcltest-21.6 {test command - setup occurs before cleanup & before script} { } set foo 1 set expected 2 - } + } -body { incr foo set foo @@ -1290,7 +1300,7 @@ test tcltest-21.7 {test command - bad flag} { } } -returnCodes 1 - -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } # alternate test command format (these are the same as 21.1-21.6, with the @@ -1310,7 +1320,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, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} test tcltest-21.9 {test command with setup} \ -setup {set foo 1} \ @@ -1424,7 +1434,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 +1457,7 @@ test tcltest-23.2 {removeFile} { } -cleanup { file delete -force $mfdir \ - [file join [temporaryDirectory] t1.tmp] + [file join [temporaryDirectory] t1.tmp] } -result {0 0} } @@ -1824,9 +1834,13 @@ 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: |