diff options
Diffstat (limited to 'tests/tcltest.test')
| -rw-r--r--[-rwxr-xr-x] | tests/tcltest.test | 323 |
1 files changed, 211 insertions, 112 deletions
diff --git a/tests/tcltest.test b/tests/tcltest.test index 09f713d..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.37 2003/01/31 22:19:30 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,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}]} { @@ -53,7 +51,7 @@ testConstraint exec [llength [info commands exec]] 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 +59,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 +80,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 +96,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] @@ -439,7 +432,7 @@ test tcltest-6.7 {tcltest::outputChannel - retrieval} { } -result {stdout} -cleanup { - set tcltest::outputChannel $of + set ::tcltest::outputChannel $of } } @@ -525,62 +518,79 @@ set a [makeFile { 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 - 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} } } - -test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {unixOnly nonRoot} { - slave msg $a -tmpdir $notReadableDir - string match {*not readable*} $msg -} {1} - -test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {unixOrPc nonRoot} { - 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 @@ -597,7 +607,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 @@ -609,35 +618,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} {unixOnly nonRoot} { - 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 { @@ -655,7 +682,6 @@ test tcltest-8.14 {testsDirectory} { set ::tcltest::testsDirectory $old } } - # [workingDirectory] test tcltest-8.60 {::workingDirectory} { -setup { @@ -668,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 } @@ -685,31 +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} { - slave msg [file join [testsDirectory] all.tcl] -file a*.test - list [regexp assocd\.test $msg] -} {1} -test tcltest-9.2 {-file a*.tcl} {unixOrPc} { +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 a*.test -notfile assocd* - list [regexp assocd\.test $msg] -} {0} + -file d*.test -notfile dstring* + regexp {dstring\.test} $msg +} -cleanup { + testsDirectory $old +} -result 0 test tcltest-9.3 {matchFiles} { -body { @@ -737,6 +775,21 @@ 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] set mc [makeFile { package require tcltest @@ -789,17 +842,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. @@ -813,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] @@ -829,6 +883,7 @@ 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 {} } @@ -888,7 +943,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 @@ -898,7 +953,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 @@ -969,7 +1024,7 @@ test tcltest-15.1 {basic directory walking} { } -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} { @@ -984,7 +1039,7 @@ test tcltest-15.2 {-asidefromdir} { } -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!$} @@ -1073,38 +1128,36 @@ 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 ... @@ -1718,13 +1771,59 @@ test tcltest-25.2 { test tcltest-25.3 { reported return code (Bug 611922) +} -setup { + set fail $::tcltest::currentFailure + set v [verbose] } -body { - # Buggy tcltest will generate result of 2 + 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 } |