diff options
Diffstat (limited to 'tests/tcltest.test')
| -rw-r--r--[-rwxr-xr-x] | tests/tcltest.test | 644 |
1 files changed, 430 insertions, 214 deletions
diff --git a/tests/tcltest.test b/tests/tcltest.test index cfbe634..ce8d617 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.29 2002/06/26 03:25:06 dgp 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,12 +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. Use of a slave -# interp might also be able to replace the [exec] of child processes -# that make this test file take so long to complete. -# -# Anyone reading this who has some time, a patch making that change -# would be welcome. +# interfere with the [test] doing the testing. # if {[catch {package require tcltest 2.1}]} { @@ -51,61 +44,98 @@ makeFile { exit } test.tcl +cd [temporaryDirectory] +testConstraint exec [llength [info commands exec]] # test -help -test tcltest-1.1 {tcltest -help} {unixOrPc} { +# Child processes because -help [exit]s. +test tcltest-1.1 {tcltest -help} {exec} { set result [catch {exec [interpreter] test.tcl -help} msg] - set result [catch {runCmd $cmd}] list $result [regexp Usage $msg] -} {1 1} -test tcltest-1.2 {tcltest -help -something} {unixOrPc} { +} {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] } {1 1} -test tcltest-1.3 {tcltest -h} {unixOrPc} { +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} { + upvar 1 $msgVar msg + + interp create [namespace current]::i + # 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]]" + i eval "set tcltest::errorChannel\ + \[[list open [set ef [makeFile {} error]] w]]" + i eval [list set argv0 [lindex $args 0]] + i eval [list set argv [lrange $args 1 end]] + i eval [list package ifneeded tcltest [package provide tcltest] \ + [package ifneeded tcltest [package provide tcltest]]] + i eval {proc exit args {}} + + # Need to capture output in msg + + set code [catch {i eval {source $argv0}}] + i eval {close $tcltest::outputChannel} + interp delete [namespace current]::i + set f [open $of] + set msg [read -nonewline $f] + close $f + set f [open $ef] + set err [read -nonewline $f] + close $f + removeFile output + removeFile error + if {[string length $err]} { + set code 1 + append msg \n$err + } + return $code +} test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} { - set result [catch {exec [interpreter] test.tcl} msg] + 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'} {unixOrPc} { - set result [catch {exec [interpreter] test.tcl -verbose 'b'} msg] + 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'} {unixOrPc} { - set result [catch {exec [interpreter] test.tcl -verbose 'p'} msg] + 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'} {unixOrPc} { - set result [catch {exec [interpreter] test.tcl -verbose 's'} msg] + 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'} {unixOrPc} { - set result [catch {exec [interpreter] test.tcl -verbose 'ps'} msg] + 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'} {unixOrPc} { - set result [catch {exec [interpreter] test.tcl -verbose 'psb'} msg] + 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'} {unixOrPc} { - set result [catch {exec [interpreter] test.tcl -verbose "pass skip body"} msg] + 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] @@ -114,7 +144,7 @@ test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} { test tcltest-2.6 {tcltest -verbose 't'} { -constraints {unixOrPc} -body { - set result [catch {exec [interpreter] test.tcl -verbose 't'} msg] + set result [slave msg test.tcl -verbose 't'] list $result $msg } -result {^0 .*a-1.0 start.*b-1.0 start} @@ -124,7 +154,7 @@ test tcltest-2.6 {tcltest -verbose 't'} { test tcltest-2.6a {tcltest -verbose 'start'} { -constraints {unixOrPc} -body { - set result [catch {exec [interpreter] test.tcl -verbose start} msg] + set result [slave msg test.tcl -verbose start] list $result $msg } -result {^0 .*a-1.0 start.*b-1.0 start} @@ -147,7 +177,7 @@ test tcltest-2.7 {tcltest::verbose} { test tcltest-2.8 {tcltest -verbose 'error'} { -constraints {unixOrPc} -body { - set result [catch {exec [interpreter] test.tcl -verbose error} msg] + set result [slave msg test.tcl -verbose error] list $result $msg } -result {errorInfo: foo.*errorCode: 9} @@ -155,22 +185,22 @@ test tcltest-2.8 {tcltest -verbose 'error'} { } # -match, [match] test tcltest-3.1 {tcltest -match 'a*'} {unixOrPc} { - set result [catch {exec [interpreter] test.tcl -match a* -verbose 'ps'} msg] + 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*'} {unixOrPc} { - set result [catch {exec [interpreter] test.tcl -match b* -verbose 'ps'} msg] + 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*'} {unixOrPc} { - set result [catch {exec [interpreter] test.tcl -match c* -verbose 'ps'} msg] + 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*'} {unixOrPc} { - set result [catch {exec [interpreter] test.tcl -match {a* b*} -verbose 'ps'} msg] + 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} @@ -190,27 +220,27 @@ test tcltest-3.5 {tcltest::match} { # -skip, [skip] test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} { - set result [catch {exec [interpreter] test.tcl -skip a* -verbose 'ps'} msg] + 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*'} {unixOrPc} { - set result [catch {exec [interpreter] test.tcl -skip b* -verbose 'ps'} msg] + 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*'} {unixOrPc} { - set result [catch {exec [interpreter] test.tcl -skip c* -verbose 'ps'} msg] + 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*'} {unixOrPc} { - set result [catch {exec [interpreter] test.tcl -skip {a* b*} -verbose 'ps'} msg] + 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*'} {unixOrPc} { - set result [catch {exec [interpreter] test.tcl -match {a* b*} -skip b* -verbose 'ps'} msg] + 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} @@ -231,12 +261,12 @@ test tcltest-4.6 {tcltest::skip} { # -constraints, -limitconstraints, [testConstraint], # $constraintsSpecified, [limitConstraints] test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} { - set result [catch {exec [interpreter] test.tcl -constraints knownBug -verbose 'ps'} msg] + 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} {unixOrPc} { - set result [catch {exec [interpreter] test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1} msg] + 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} @@ -279,11 +309,11 @@ test tcltest-5.5 {InitConstraints: list of built-in constraints} \ -setup {tcltest::InitConstraints} \ -body { lsort [array names ::tcltest::testConstraints] } \ -result [lsort { - 95 98 asyncPipeClose eformat emptyTest hasIsoLocale interactive knownBug - mac macCrash macOnly macOrPc macOrUnix macOrWin nonBlockFiles nonPortable - notRoot nt pc pcCrash pcOnly root singleTestInterp socket stdio tempNotMac - tempNotPc tempNotUnix tempNotWin unix unixCrash unixExecs unixOnly unixOrPc - unixOrWin userInteraction win winCrash winOnly + 95 98 asyncPipeClose eformat emptyTest exec hasIsoLocale interactive + knownBug mac macCrash macOnly macOrPc macOrUnix macOrWin nonBlockFiles + nonPortable notRoot nt pc pcCrash pcOnly root singleTestInterp socket + stdio tempNotMac tempNotPc tempNotUnix tempNotWin unix unixCrash unixExecs + unixOnly unixOrPc unixOrWin userInteraction win winCrash winOnly }] # Removed this broken test. Its usage of [limitConstraints] was not @@ -326,28 +356,28 @@ set printerror [makeFile { test tcltest-6.1 {tcltest -outfile, -errfile defaults} { -constraints unixOrPc -body { - catch {exec [interpreter] $printerror} msg + slave msg $printerror return $msg } -result {a test.*a really} -match regexp } test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} { - catch {exec [interpreter] printerror.tcl -outfile a.tmp} msg + 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] } {0 1 0 1 1 {}} test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} { - catch {exec [interpreter] printerror.tcl -errfile a.tmp} msg + 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} {unixOrPc unixExecs} { - catch {exec [interpreter] printerror.tcl -outfile a.tmp -errfile b.tmp} msg + 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] \ @@ -389,6 +419,7 @@ test tcltest-6.6 {tcltest::errorFile (implicit errorChannel)} { -match regexp -cleanup { errorFile $of + removeFile efile } } test tcltest-6.7 {tcltest::outputChannel - retrieval} { @@ -401,7 +432,7 @@ test tcltest-6.7 {tcltest::outputChannel - retrieval} { } -result {stdout} -cleanup { - set tcltest::outputChannel $of + set ::tcltest::outputChannel $of } } @@ -424,10 +455,14 @@ test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} { -match regexp -cleanup { outputFile $of + removeFile efile } } # -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 +# 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 @@ -469,76 +504,93 @@ test tcltest-7.6 {tcltest::debug} { set ::tcltest::debug $old } } +removeFile test.tcl # directory tests -makeFile { +set a [makeFile { package require tcltest tcltest::makeFile {} a.tmp - puts "testdir: [tcltest::testsDirectory]" + puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]" exit -} a.tcl +} a.tcl] -makeFile {} thisdirectoryisafile +set tdiaf [makeFile {} thisdirectoryisafile] set normaldirectory [makeDirectory normaldirectory] -if {$::tcl_platform(platform) == "macintosh"} { -set normaldirectory [file normalize $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 + file exists [file join thisdirectorydoesnotexist a.tmp] +} -cleanup { file delete -force thisdirectorydoesnotexist - exec [interpreter] a.tcl -tmpdir thisdirectorydoesnotexist - list [file exists [file join thisdirectorydoesnotexist a.tmp]] \ - [file delete -force thisdirectorydoesnotexist] -} {1 {}} +} -result 1 test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} { -constraints unixOrPc -body { - catch {exec [interpreter] a.tcl -tmpdir thisdirectoryisafile} msg - set msg + slave msg $a -tmpdir $tdiaf + 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} } } - -test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {unixOnly} { - catch {exec [interpreter] a.tcl -tmpdir $notReadableDir} msg - string match {*not readable*} $msg -} {1} - -test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {unixOrPc} { - catch {exec [interpreter] a.tcl -tmpdir $notWriteableDir} msg - string match {*not writeable*} $msg -} {1} - -test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {unixOrPc} { - catch {exec [interpreter] a.tcl -tmpdir $normaldirectory} msg - # 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 {}} - - -set current [pwd] +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 @@ -546,58 +598,77 @@ test tcltest-8.6 {temporaryDirectory} { } -body { set f1 [temporaryDirectory] - set f2 [temporaryDirectory $current] + set f2 [temporaryDirectory [workingDirectory]] set f3 [temporaryDirectory] list $f1 $f2 $f3 } - -result "[list $normaldirectory $current $current]" + -result "[list $normaldirectory [workingDirectory] [workingDirectory]]" -cleanup { set ::tcltest::temporaryDirectory $old } } - test tcltest-8.6a {temporaryDirectory - test format 2} -setup { set old $::tcltest::temporaryDirectory set ::tcltest::temporaryDirectory $normaldirectory } -body { set f1 [temporaryDirectory] - set f2 [temporaryDirectory $current] + set f2 [temporaryDirectory [workingDirectory]] set f3 [temporaryDirectory] list $f1 $f2 $f3 } -cleanup { set ::tcltest::temporaryDirectory $old -} -result [list $normaldirectory $current $current] - +} -result [list $normaldirectory [workingDirectory] [workingDirectory]] +cd [temporaryDirectory] # -testdir, [testsDirectory] -test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {unixOrPc} { - file delete -force thisdirectorydoesnotexist - catch {exec [interpreter] a.tcl -testdir thisdirectorydoesnotexist} msg - string match "*does not exist*" $msg -} {1} - -test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {unixOrPc} { - catch {exec [interpreter] a.tcl -testdir thisdirectoryisafile} msg - string match "*not a directory*" $msg -} {1} - -test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {unixOnly} { - catch {exec [interpreter] a.tcl -testdir $notReadableDir} msg - string match {*not readable*} $msg -} {1} - - -test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {unixOrPc} { - catch {exec [interpreter] a.tcl -testdir $normaldirectory} msg - # 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 { set old $::tcltest::testsDirectory - set current [pwd] set ::tcltest::testsDirectory $normaldirectory } -body { @@ -611,7 +682,6 @@ test tcltest-8.14 {testsDirectory} { set ::tcltest::testsDirectory $old } } - # [workingDirectory] test tcltest-8.60 {::workingDirectory} { -setup { @@ -624,7 +694,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 } @@ -641,30 +711,43 @@ 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 777 $notWriteableDir} catch {file attributes $notWriteableDir -readonly 0} } } -file delete -force $notReadableDir $notWriteableDir +file delete -force -- $notReadableDir $notWriteableDir +removeFile a.tcl +removeFile thisdirectoryisafile +removeDirectory normaldirectory # -file, -notfile, [matchFiles], [skipFiles] -test tcltest-9.1 {-file a*.tcl} {unixOrPc} { - catch {exec [interpreter] \ - [file join [testsDirectory] all.tcl] -file a*.test} msg - list [regexp assocd\.test $msg] -} {1} -test tcltest-9.2 {-file a*.tcl} {unixOrPc} { - catch {exec [interpreter] \ - [file join [testsDirectory] all.tcl] \ - -file a*.test -notfile assocd*} msg - list [regexp assocd\.test $msg] -} {0} +test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup { + set old [testsDirectory] + testsDirectory [file dirname [info script]] +} -body { + 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 {unixOrPc} -setup { + set old [testsDirectory] + testsDirectory [file dirname [info script]] +} -body { + slave msg [file join [testsDirectory] all.tcl] \ + -file d*.test -notfile dstring* + regexp {dstring\.test} $msg +} -cleanup { + testsDirectory $old +} -result 0 test tcltest-9.3 {matchFiles} { -body { @@ -692,8 +775,23 @@ test tcltest-9.4 {skipFiles} { -result {foo bar} } +test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup { + set d [makeDirectory tmp] + makeDirectory foo $d + makeFile {} fee $d + file copy [file join [file dirname [info script]] all.tcl] $d +} -body { + slave msg [file join [temporaryDirectory] all.tcl] -file f* + regexp {exiting with errors:} $msg +} -cleanup { + file delete [file join $d all.tcl] + removeFile fee $d + removeDirectory foo $d + removeDirectory tmp +} -result 0 + # -preservecore, [preserveCore] -makeFile { +set mc [makeFile { package require tcltest namespace import ::tcltest::test test makecore {make a core file} { @@ -702,26 +800,27 @@ makeFile { } {} ::tcltest::cleanupTests return -} makecore.tcl +} makecore.tcl] +cd [temporaryDirectory] test tcltest-10.1 {-preservecore 0} {unixOrPc} { - catch {exec [interpreter] makecore.tcl -preservecore 0} msg + slave msg $mc -preservecore 0 file delete core regexp "Core file produced" $msg } {0} test tcltest-10.2 {-preservecore 1} {unixOrPc} { - catch {exec [interpreter] makecore.tcl -preservecore 1} msg + slave msg $mc -preservecore 1 file delete core regexp "Core file produced" $msg } {1} test tcltest-10.3 {-preservecore 2} {unixOrPc} { - catch {exec [interpreter] makecore.tcl -preservecore 2} msg + 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} {unixOrPc} { - catch {exec [interpreter] makecore.tcl -preservecore 3} msg + 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] @@ -729,7 +828,7 @@ test tcltest-10.4 {-preservecore 3} {unixOrPc} { # Removing this test. It makes no sense to test the ability of # [preserveCore] to accept an invalid value that will cause errors -# in other parts of tcltests' operation. +# in other parts of tcltest's operation. #test tcltest-10.5 {preserveCore} { # -body { # set old [preserveCore] @@ -740,21 +839,25 @@ test tcltest-10.4 {-preservecore 3} {unixOrPc} { # } # -result {foo foo} #} +removeFile makecore.tcl # -load, -loadfile, [loadScript], [loadFile] -set loadfile [makeFile { +set contents { package require tcltest - puts $::tcltest::loadScript + namespace import tcltest::* + puts [outputChannel] $::tcltest::loadScript exit -} load.tcl] +} +set loadfile [makeFile $contents load.tcl] test tcltest-12.1 {-load xxx} {unixOrPc} { - catch {exec [interpreter] load.tcl -load xxx} msg - set msg + slave msg $loadfile -load xxx + return $msg } {xxx} +# Using child process because of -debug usage. test tcltest-12.2 {-loadfile load.tcl} {unixOrPc} { - catch {exec [interpreter] load.tcl -debug 2 -loadfile load.tcl} msg + catch {exec [interpreter] $loadfile -debug 2 -loadfile $loadfile} msg list \ [regexp {tcltest} [join [list $msg] [split $msg \n]]] \ [regexp {loadScript} [join [list $msg] [split $msg \n]]] @@ -763,6 +866,7 @@ test tcltest-12.2 {-loadfile load.tcl} {unixOrPc} { test tcltest-12.3 {loadScript} { -setup { set old $::tcltest::loadScript + set ::tcltest::loadScript {} } -body { set f1 [loadScript] @@ -779,27 +883,25 @@ test tcltest-12.3 {loadScript} { test tcltest-12.4 {loadFile} { -setup { set olds $::tcltest::loadScript + set ::tcltest::loadScript {} set oldf $::tcltest::loadFile set ::tcltest::loadFile {} } -body { set f1 [loadScript] set f2 [loadFile] - set f3 [loadFile load.tcl] + set f3 [loadFile $loadfile] set f4 [loadScript] set f5 [loadFile] list $f1 $f2 $f3 $f4 $f5 } - -result "[list {} {} $loadfile { - package require tcltest - puts $::tcltest::loadScript - exit -} $loadfile]\n" + -result "[list {} {} $loadfile $contents $loadfile]\n" -cleanup { set ::tcltest::loadScript $olds set ::tcltest::loadFile $oldf } } +removeFile load.tcl # [interpreter] test tcltest-13.1 {interpreter} { @@ -820,26 +922,28 @@ test tcltest-13.1 {interpreter} { } # -singleproc, [singleProcess] -makeDirectory singleprocdir +set spd [makeDirectory singleprocdir] makeFile { set foo 1 -} [file join singleprocdir single1.test] +} single1.test $spd makeFile { unset foo -} [file join singleprocdir single2.test] +} single2.test $spd set allfile [makeFile { package require tcltest namespace import tcltest::* testsDirectory [file join [temporaryDirectory] singleprocdir] runAllTests -} [file join singleprocdir all-single.tcl]] +} all-single.tcl $spd] +cd [workingDirectory] test tcltest-14.1 {-singleproc - single process} { -constraints {unixOrPc} -body { - exec [interpreter] $allfile -singleproc 0 + slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory] + return $msg } -result {Test file error: can't unset .foo.: no such variable} -match regexp @@ -848,7 +952,8 @@ test tcltest-14.1 {-singleproc - single process} { test tcltest-14.2 {-singleproc - multiple process} { -constraints {unixOrPc} -body { - exec [interpreter] $allfile -singleproc 1 + 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} -match regexp @@ -870,61 +975,71 @@ test tcltest-14.3 {singleProcess} { set ::tcltest::singleProcess $old } } +removeFile single1.test $spd +removeFile single2.test $spd +removeDirectory singleprocdir # -asidefromdir, -relateddir, [matchDirectories], [skipDirectories] # Before running these tests, need to set up test subdirectories with their own # all.tcl files. -makeDirectory dirtestdir -makeDirectory [file join dirtestdir dirtestdir2.1] -makeDirectory [file join dirtestdir dirtestdir2.2] -makeDirectory [file join dirtestdir dirtestdir2.3] +set dtd [makeDirectory dirtestdir] +set dtd1 [makeDirectory dirtestdir2.1 $dtd] +set dtd2 [makeDirectory dirtestdir2.2 $dtd] +set dtd3 [makeDirectory dirtestdir2.3 $dtd] makeFile { package require tcltest namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir] runAllTests -} [file join dirtestdir all.tcl] +} all.tcl $dtd makeFile { package require tcltest namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.1] runAllTests -} [file join dirtestdir dirtestdir2.1 all.tcl] +} all.tcl $dtd1 makeFile { package require tcltest namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.2] runAllTests -} [file join dirtestdir dirtestdir2.2 all.tcl] +} all.tcl $dtd2 makeFile { package require tcltest namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3] runAllTests -} [file join dirtestdir dirtestdir2.3 all.tcl] +} all.tcl $dtd3 test tcltest-15.1 {basic directory walking} { -constraints {unixOrPc} -body { - exec [interpreter] [file join [temporaryDirectory] dirtestdir all.tcl] + if {[slave msg \ + [file join $dtd all.tcl] \ + -tmpdir [temporaryDirectory]] == 1} { + error $msg + } } -match regexp -returnCodes 1 - -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.1.*Tests located in:.*dirtestdir2.2.*Tests located in:.*dirtestdir2.3} + -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123]} } test tcltest-15.2 {-asidefromdir} { -constraints {unixOrPc} -body { - exec [interpreter] \ - [file join [temporaryDirectory] dirtestdir all.tcl] \ - -asidefromdir dirtestdir2.3 + if {[slave msg \ + [file join $dtd all.tcl] \ + -asidefromdir dirtestdir2.3 \ + -tmpdir [temporaryDirectory]] == 1} { + error $msg + } } -match regexp -returnCodes 1 - -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.1.*Tests located in:.*dirtestdir2.2.*dirtestdir2.2 test ended at .*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.[12].*Tests located in:.*dirtestdir2.[12].*dirtestdir2.[12] test ended at .*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Error: No test files remain after applying your match and skip patterns! Error: No test files remain after applying your match and skip patterns! Error: No test files remain after applying your match and skip patterns!$} @@ -933,9 +1048,12 @@ Error: No test files remain after applying your match and skip patterns!$} test tcltest-15.3 {-relateddir, non-existent dir} { -constraints {unixOrPc} -body { - exec [interpreter] \ - [file join [temporaryDirectory] dirtestdir all.tcl] \ - -relateddir [file join [temporaryDirectory] dirtestdir0] + if {[slave msg \ + [file join $dtd all.tcl] \ + -relateddir [file join [temporaryDirectory] dirtestdir0] \ + -tmpdir [temporaryDirectory]] == 1} { + error $msg + } } -returnCodes 1 -match regexp @@ -945,9 +1063,11 @@ test tcltest-15.3 {-relateddir, non-existent dir} { test tcltest-15.4 {-relateddir, subdir} { -constraints {unixOrPc} -body { - exec [interpreter] \ - [file join [temporaryDirectory] dirtestdir all.tcl] \ - -relateddir dirtestdir2.1 + if {[slave msg \ + [file join $dtd all.tcl] \ + -relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} { + error $msg + } } -returnCodes 1 -match regexp @@ -956,10 +1076,13 @@ test tcltest-15.4 {-relateddir, subdir} { test tcltest-15.5 {-relateddir, -asidefromdir} { -constraints {unixOrPc} -body { - exec [interpreter] \ - [file join [temporaryDirectory] dirtestdir all.tcl] \ + if {[slave msg \ + [file join $dtd all.tcl] \ -relateddir "dirtestdir2.1 dirtestdir2.2" \ - -asidefromdir dirtestdir2.2 + -asidefromdir dirtestdir2.2 \ + -tmpdir [temporaryDirectory]] == 1} { + error $msg + } } -match regexp -returnCodes 1 @@ -999,50 +1122,55 @@ test tcltest-15.7 {skipDirectories} { } -result {{} foo foo} } +removeDirectory dirtestdir2.3 $dtd +removeDirectory dirtestdir2.2 $dtd +removeDirectory dirtestdir2.1 $dtd +removeDirectory dirtestdir # TCLTEST_OPTIONS -test tcltest-19.1 {TCLTEST_OPTIONS default} { - -constraints {unixOrPc singleTestInterp} - -setup { +test tcltest-19.1 {TCLTEST_OPTIONS default} -setup { if {[info exists ::env(TCLTEST_OPTIONS)]} { set oldoptions $::env(TCLTEST_OPTIONS) - unset ::env(TCLTEST_OPTIONS) } else { set oldoptions none } # 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) { } - set olddebug [debug] - debug 2 - } - -cleanup { - if {$oldoptions == "none"} { + interp create slave1 + slave1 eval [list set argv {-debug 2}] + slave1 alias puts puts + interp create slave2 + slave2 alias puts puts + } -cleanup { + interp delete slave2 + interp delete slave1 + if {$oldoptions eq "none"} { unset ::env(TCLTEST_OPTIONS) } else { set ::env(TCLTEST_OPTIONS) $oldoptions } - debug $olddebug - } - -body { - ::tcltest::ProcessCmdLineArgs + } -body { + slave1 eval [package ifneeded tcltest [package provide tcltest]] + slave1 eval tcltest::debug set ::env(TCLTEST_OPTIONS) "-debug 3" - ::tcltest::ProcessCmdLineArgs - } - -result {^$} - -match regexp - -output {tcltest::debug\s+= 2.*tcltest::debug\s+= 3} -} + 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} # Begin testing of tcltest procs ... +cd [temporaryDirectory] # PrintError test tcltest-20.1 {PrintError} {unixOrPc} { - set result [catch {exec [interpreter] printerror.tcl} msg] + 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] } {1 1 1 1 1 1} +cd [workingDirectory] +removeFile printerror.tcl # test::test test tcltest-21.0 {name and desc but no args specified} -setup { @@ -1245,19 +1373,19 @@ test tcltest-21.12 { # test all.tcl usage (runAllTests); simulate .test file failure, as well as # crashes to determine whether or not these errors are logged. -makeDirectory alltestdir +set atd [makeDirectory alltestdir] makeFile { package require tcltest namespace import -force tcltest::* testsDirectory [file join [temporaryDirectory] alltestdir] runAllTests -} [file join alltestdir all.tcl] +} all.tcl $atd makeFile { exit 1 -} [file join alltestdir exit.test] +} exit.test $atd makeFile { error "throw an error" -} [file join alltestdir error.test] +} error.test $atd makeFile { package require tcltest namespace import -force tcltest::* @@ -1266,16 +1394,21 @@ makeFile { -result {1} } cleanupTests -} [file join alltestdir test.test] +} test.test $atd +# Must use a child process because stdout/stderr parsing can't be +# duplicated in slave interp. test tcltest-22.1 {runAllTests} { -constraints {unixOrPc} -body { - exec [interpreter] [file join [temporaryDirectory] alltestdir all.tcl] -verbose t + exec [interpreter] \ + [file join $atd all.tcl] \ + -verbose t -tmpdir [temporaryDirectory] } -match regexp -result "Test files exiting with errors:.*error.test.*exit.test" } +removeDirectory alltestdir # makeFile, removeFile, makeDirectory, removeDirectory, viewFile test tcltest-23.1 {makeFile} { @@ -1333,15 +1466,16 @@ test tcltest-23.3 {makeDirectory} { -result {1 1} } test tcltest-23.4 {removeDirectory} { - -body { - set mfdir [file join [temporaryDirectory] mfdir] - file mkdir $mfdir - file mkdir [file join [temporaryDirectory] t1] - file mkdir [file join [temporaryDirectory] $mfdir t2] + -setup { + set mfdir [makeDirectory mfdir] + makeDirectory t1 + makeDirectory t2 $mfdir if {![file exists $mfdir] || \ ![file exists [file join [temporaryDirectory] $mfdir t2]]} { - return "setup failed - directory not created" + error "setup failed - directory not created" } + } + -body { removeDirectory t1 removeDirectory t2 $mfdir list [file exists [file join [temporaryDirectory] t1]] \ @@ -1360,6 +1494,7 @@ test tcltest-23.5 {viewFile} { -result {foobar foobarbaz} -cleanup { file delete -force $mfdir + removeFile t1.tmp } } @@ -1609,6 +1744,87 @@ test tcltest-24.20 { *(negative matching): *} +test tcltest-25.1 { + constraint of setup/cleanup (Bug 589859) +} -setup { + set foo 0 +} -body { + # Buggy tcltest will generate result of 2 + test tcltest-25.1.0 {} -constraints knownBug -setup { + incr foo + } -body { + incr foo + } -cleanup { + incr foo + } -match glob -result * + set foo +} -cleanup { + unset foo +} -result 0 + +test tcltest-25.2 { + puts -nonewline (Bug 612786) +} -body { + puts -nonewline stdout bla + puts -nonewline stdout bla +} -output {blabla} + +test tcltest-25.3 { + reported return code (Bug 611922) +} -setup { + set fail $::tcltest::currentFailure + set v [verbose] +} -body { + verbose {} + test tcltest-25.3.0 {} -body { + error foo + } +} -cleanup { + set ::tcltest::currentFailure $fail + verbose $v +} -match glob -output {*generated error; Return code was: 1*} + +test tcltest-26.1 {Bug/RFE 1017151} -setup { + makeFile { + package require tcltest + set ::errorInfo "Should never see this" + tcltest::test tcltest-26.1.0 { + no errorInfo when only return code mismatch + } -body { + set x 1 + } -returnCodes error -result 1 + tcltest::cleanupTests + } test.tcl +} -body { + slave msg [file join [temporaryDirectory] test.tcl] + return $msg +} -cleanup { + removeFile test.tcl +} -match glob -result {* +---- Return code should have been one of: 1 +==== tcltest-26.1.0 FAILED*} + +test tcltest-26.2 {Bug/RFE 1017151} -setup { + makeFile { + package require tcltest + set ::errorInfo "Should never see this" + tcltest::test tcltest-26.2.0 {do not mask body errorInfo} -body { + error "body error" + } -cleanup { + error "cleanup error" + } -result 1 + tcltest::cleanupTests + } test.tcl +} -body { + slave msg [file join [temporaryDirectory] test.tcl] + return $msg +} -cleanup { + removeFile test.tcl +} -match glob -result {* +---- errorInfo: body error +* +---- errorInfo(cleanup): cleanup error*} + cleanupTests } |