diff options
Diffstat (limited to 'tests/tcltest.test')
| -rw-r--r--[-rwxr-xr-x] | tests/tcltest.test | 239 |
1 files changed, 136 insertions, 103 deletions
diff --git a/tests/tcltest.test b/tests/tcltest.test index 7515a80..728a018 100755..100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -2,13 +2,11 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2000 by Ajuba Solutions # All rights reserved. -# -# RCS: @(#) $Id: tcltest.test,v 1.53 2006/03/18 18:15:13 vincentdarley Exp $ -# Note that there are several places where the value of +# Note that there are several places where the value of # tcltest::currentFailure is stored/reset in the -setup/-cleanup # of a test that has a body that runs [test] that will fail. # This is a workaround of using the same tcltest code that we are @@ -16,7 +14,7 @@ # # It would be better to have the -body of the tests run the tcltest # commands in a slave interp so the [test] being tested would not -# interfere with the [test] doing the testing. +# interfere with the [test] doing the testing. # if {[catch {package require tcltest 2.1}]} { @@ -48,12 +46,13 @@ makeFile { cd [temporaryDirectory] testConstraint exec [llength [info commands exec]] + # test -help # Child processes because -help [exit]s. test tcltest-1.1 {tcltest -help} {exec} { set result [catch {exec [interpreter] test.tcl -help} msg] list $result [regexp Usage $msg] -} {1 1} +} {1 1} test tcltest-1.2 {tcltest -help -something} {exec} { set result [catch {exec [interpreter] test.tcl -help -something} msg] list $result [regexp Usage $msg] @@ -61,7 +60,7 @@ test tcltest-1.2 {tcltest -help -something} {exec} { test tcltest-1.3 {tcltest -h} {exec} { set result [catch {exec [interpreter] test.tcl -h} msg] list $result [regexp Usage $msg] -} {1 0} +} {1 0} # -verbose, implicit & explicit testing of [verbose] proc slave {msgVar args} { @@ -82,10 +81,7 @@ proc slave {msgVar args} { # Need to capture output in msg - set code [catch {i eval {source $argv0}} foo] -if $code { -#puts "$code: $foo\n$::errorInfo" -} + set code [catch {i eval {source $argv0}}] i eval {close $tcltest::outputChannel} interp delete [namespace current]::i set f [open $of] @@ -101,8 +97,6 @@ if $code { append msg \n$err } return $code - -# return [catch {uplevel 1 [linsert $args 0 exec [interpreter]]} msg] } test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} { set result [slave msg test.tcl] @@ -149,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 @@ -159,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 @@ -176,7 +170,7 @@ test tcltest-2.7 {tcltest::verbose} { verbose foo set newVerbosity [verbose] verbose $oldVerbosity - list $currentVerbosity $newVerbosity + list $currentVerbosity $newVerbosity } -result {body {}} } @@ -224,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'] @@ -306,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) # } #} @@ -355,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] @@ -374,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 @@ -420,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 @@ -439,7 +433,7 @@ test tcltest-6.7 {tcltest::outputChannel - retrieval} { } -result {stdout} -cleanup { - set tcltest::outputChannel $of + set ::tcltest::outputChannel $of } } @@ -456,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 @@ -528,58 +522,76 @@ set normaldirectory [makeDirectory normaldirectory] normalizePath normaldirectory # -tmpdir, [temporaryDirectory] -test tcltest-8.1 {tcltest a.tcl -tmpdir a} {unixOrPc} { +test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrPc -setup { file delete -force thisdirectorydoesnotexist +} -body { slave msg $a -tmpdir thisdirectorydoesnotexist - list [file exists [file join thisdirectorydoesnotexist a.tmp]] \ - [file delete -force thisdirectorydoesnotexist] -} {1 {}} + file exists [file join thisdirectorydoesnotexist a.tmp] +} -cleanup { + file delete -force thisdirectorydoesnotexist +} -result 1 test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} { -constraints unixOrPc -body { slave msg $a -tmpdir $tdiaf - set msg + return $msg } -result {*not a directory*} -match glob } - # Test non-writeable directories, non-readable directories with directory flags set notReadableDir [file join [temporaryDirectory] notreadable] set notWriteableDir [file join [temporaryDirectory] notwriteable] - makeDirectory notreadable makeDirectory notwriteable - -switch -- $tcl_platform(platform) { - "unix" { +switch -- $::tcl_platform(platform) { + unix { file attributes $notReadableDir -permissions 00333 file attributes $notWriteableDir -permissions 00555 } default { catch {file attributes $notWriteableDir -readonly 1} - catch {testchmod 000 $notWriteableDir} + catch {testchmod 0 $notWriteableDir} } } - -test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {unix notRoot} { - slave msg $a -tmpdir $notReadableDir - string match {*not readable*} $msg -} {1} - -test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {unixOrPc notRoot} { - slave msg $a -tmpdir $notWriteableDir - string match {*not writeable*} $msg -} {1} - -test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {unixOrPc} { - slave msg $a -tmpdir $normaldirectory - # The join is necessary because the message can be split on multiple lines - list [file exists [file join $normaldirectory a.tmp]] \ - [file delete [file join $normaldirectory a.tmp]] -} {1 {}} +test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} { + -constraints {unix notRoot} + -body { + slave msg $a -tmpdir $notReadableDir + return $msg + } + -result {*not readable*} + -match glob +} +# 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]] +}] +# 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 { + slave msg $a -tmpdir $notWriteableDir + return $msg + } + -result {*not writeable*} + -match glob +} +test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} { + -constraints unixOrPc + -body { + 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] + } + -cleanup { + catch {file delete [file join $normaldirectory a.tmp]} + } + -result 1 +} cd [workingDirectory] - test tcltest-8.6 {temporaryDirectory} { -setup { set old $::tcltest::temporaryDirectory @@ -596,7 +608,6 @@ test tcltest-8.6 {temporaryDirectory} { set ::tcltest::temporaryDirectory $old } } - test tcltest-8.6a {temporaryDirectory - test format 2} -setup { set old $::tcltest::temporaryDirectory set ::tcltest::temporaryDirectory $normaldirectory @@ -608,35 +619,53 @@ test tcltest-8.6a {temporaryDirectory - test format 2} -setup { } -cleanup { set ::tcltest::temporaryDirectory $old } -result [list $normaldirectory [workingDirectory] [workingDirectory]] - cd [temporaryDirectory] # -testdir, [testsDirectory] -test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {unixOrPc} { - file delete -force thisdirectorydoesnotexist - slave msg $a -testdir thisdirectorydoesnotexist - string match "*does not exist*" $msg -} {1} - -test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {unixOrPc} { - slave msg $a -testdir $tdiaf - string match "*not a directory*" $msg -} {1} - -test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {unix notRoot} { - slave msg $a -testdir $notReadableDir - string match {*not readable*} $msg -} {1} - - -test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {unixOrPc} { - 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]] \ - [file exists [file join [temporaryDirectory] a.tmp]] \ - [file delete [file join [temporaryDirectory] a.tmp]] -} {0 1 {}} +test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} { + -constraints unixOrPc + -setup { + file delete -force thisdirectorydoesnotexist + } + -body { + slave msg $a -testdir thisdirectorydoesnotexist + return $msg + } + -match glob + -result {*does not exist*} +} +test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} { + -constraints unixOrPc + -body { + 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} + -body { + slave msg $a -testdir $notReadableDir + return $msg + } + -match glob + -result {*not readable*} +} +test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} { + -constraints unixOrPc + -body { + 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]] \ + [file exists [file join [temporaryDirectory] a.tmp]] + } + -cleanup { + file delete [file join [temporaryDirectory] a.tmp] + } + -result {0 1} +} cd [workingDirectory] - set current [pwd] test tcltest-8.14 {testsDirectory} { -setup { @@ -654,7 +683,6 @@ test tcltest-8.14 {testsDirectory} { set ::tcltest::testsDirectory $old } } - # [workingDirectory] test tcltest-8.60 {::workingDirectory} { -setup { @@ -667,7 +695,7 @@ test tcltest-8.60 {::workingDirectory} { set f1 [workingDirectory] set f2 [pwd] set f3 [workingDirectory $current] - set f4 [pwd] + set f4 [pwd] set f5 [workingDirectory] list $f1 $f2 $f3 $f4 $f5 } @@ -684,17 +712,18 @@ test tcltest-8.60 {::workingDirectory} { # clean up from directory testing -switch $tcl_platform(platform) { - "unix" { +switch -- $::tcl_platform(platform) { + unix { file attributes $notReadableDir -permissions 777 file attributes $notWriteableDir -permissions 777 } default { + catch {testchmod 0o777 $notWriteableDir} catch {file attributes $notWriteableDir -readonly 0} } } -file delete -force $notReadableDir $notWriteableDir +file delete -force -- $notReadableDir $notWriteableDir removeFile a.tcl removeFile thisdirectoryisafile removeDirectory normaldirectory @@ -705,7 +734,7 @@ test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup { testsDirectory [file dirname [info script]] } -body { slave msg [file join [testsDirectory] all.tcl] -file d*.test - set msg + return $msg } -cleanup { testsDirectory $old } -match regexp -result {dstring\.test} @@ -730,7 +759,7 @@ test tcltest-9.3 {matchFiles} { set new [matchFiles] matchFiles $old list $current $new - } + } -result {foo bar} } @@ -743,7 +772,7 @@ test tcltest-9.4 {skipFiles} { set new [skipFiles] skipFiles $old list $current $new - } + } -result {foo bar} } @@ -814,17 +843,17 @@ test tcltest-10.4 {-preservecore 3} {unixOrPc} { removeFile makecore.tcl # -load, -loadfile, [loadScript], [loadFile] -set contents { +set contents { package require tcltest namespace import tcltest::* puts [outputChannel] $::tcltest::loadScript exit -} +} set loadfile [makeFile $contents load.tcl] test tcltest-12.1 {-load xxx} {unixOrPc} { slave msg $loadfile -load xxx - set msg + return $msg } {xxx} # Using child process because of -debug usage. @@ -915,7 +944,7 @@ test tcltest-14.1 {-singleproc - single process} { -constraints {unixOrPc} -body { slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory] - set msg + return $msg } -result {Test file error: can't unset .foo.: no such variable} -match regexp @@ -925,7 +954,7 @@ test tcltest-14.2 {-singleproc - multiple process} { -constraints {unixOrPc} -body { slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory] - set msg + return $msg } -result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0} -match regexp @@ -1117,8 +1146,8 @@ test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { } -cleanup { interp delete slave2 interp delete slave1 - if {$oldoptions == "none"} { - unset ::env(TCLTEST_OPTIONS) + if {$oldoptions eq "none"} { + unset ::env(TCLTEST_OPTIONS) } else { set ::env(TCLTEST_OPTIONS) $oldoptions } @@ -1232,7 +1261,7 @@ test tcltest-21.6 {test command - setup occurs before cleanup & before script} { } set foo 1 set expected 2 - } + } -body { incr foo set foo @@ -1396,7 +1425,7 @@ test tcltest-23.1 {makeFile} { } -cleanup { file delete -force $mfdir \ - [file join [temporaryDirectory] t1.tmp] + [file join [temporaryDirectory] t1.tmp] } -result {1 1} } @@ -1419,7 +1448,7 @@ test tcltest-23.2 {removeFile} { } -cleanup { file delete -force $mfdir \ - [file join [temporaryDirectory] t1.tmp] + [file join [temporaryDirectory] t1.tmp] } -result {0 0} } @@ -1759,7 +1788,7 @@ test tcltest-25.3 { test tcltest-26.1 {Bug/RFE 1017151} -setup { makeFile { package require tcltest - set errorInfo "Should never see this" + set ::errorInfo "Should never see this" tcltest::test tcltest-26.1.0 { no errorInfo when only return code mismatch } -body { @@ -1769,7 +1798,7 @@ test tcltest-26.1 {Bug/RFE 1017151} -setup { } test.tcl } -body { slave msg [file join [temporaryDirectory] test.tcl] - set msg + return $msg } -cleanup { removeFile test.tcl } -match glob -result {* @@ -1779,7 +1808,7 @@ test tcltest-26.1 {Bug/RFE 1017151} -setup { test tcltest-26.2 {Bug/RFE 1017151} -setup { makeFile { package require tcltest - set errorInfo "Should never see this" + set ::errorInfo "Should never see this" tcltest::test tcltest-26.2.0 {do not mask body errorInfo} -body { error "body error" } -cleanup { @@ -1789,16 +1818,20 @@ test tcltest-26.2 {Bug/RFE 1017151} -setup { } test.tcl } -body { slave msg [file join [temporaryDirectory] test.tcl] - set msg + return $msg } -cleanup { removeFile test.tcl } -match glob -result {* ---- errorInfo: body error * ---- errorInfo(cleanup): cleanup error*} - + cleanupTests } namespace delete ::tcltest::test return + +# Local Variables: +# mode: tcl +# End: |