diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2016-12-21 22:47:21 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2016-12-21 22:47:21 (GMT) |
commit | 5514e37335c012cc70f5b9aee3cedfe3d57f583f (patch) | |
tree | 4ba7d8aad13735e52f59bdce7ca5ba3151ebd7e3 /tcl8.6/tests/tcltest.test | |
parent | 768f87f613cc9789fcf8073018fa02178c8c91df (diff) | |
download | blt-5514e37335c012cc70f5b9aee3cedfe3d57f583f.zip blt-5514e37335c012cc70f5b9aee3cedfe3d57f583f.tar.gz blt-5514e37335c012cc70f5b9aee3cedfe3d57f583f.tar.bz2 |
undo subtree
Diffstat (limited to 'tcl8.6/tests/tcltest.test')
-rw-r--r-- | tcl8.6/tests/tcltest.test | 1837 |
1 files changed, 0 insertions, 1837 deletions
diff --git a/tcl8.6/tests/tcltest.test b/tcl8.6/tests/tcltest.test deleted file mode 100644 index 728a018..0000000 --- a/tcl8.6/tests/tcltest.test +++ /dev/null @@ -1,1837 +0,0 @@ -# This file contains a collection of tests for one or more of the Tcl -# 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) 2000 by Ajuba Solutions -# All rights reserved. - -# 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 -# 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 slave interp so the [test] being tested would not -# interfere with the [test] doing the testing. -# - -if {[catch {package require tcltest 2.1}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.1 required." - return -} - -namespace eval ::tcltest::test { - -namespace import ::tcltest::* - -makeFile { - package require tcltest - namespace import ::tcltest::test - test a-1.0 {test a} { - list 0 - } {0} - test b-1.0 {test b} { - list 1 - } {0} - test c-1.0 {test c} {knownBug} { - } {} - test d-1.0 {test d} { - error "foo" foo 9 - } {} - tcltest::cleanupTests - exit -} test.tcl - -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} -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} {exec} { - set result [catch {exec [interpreter] test.tcl -h} msg] - list $result [regexp Usage $msg] -} {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 [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 [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 [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 [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 [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 [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 [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 {unixOrPc} - -body { - set result [slave msg test.tcl -verbose 't'] - list $result $msg - } - -result {^0 .*a-1.0 start.*b-1.0 start} - -match regexp -} - -test tcltest-2.6a {tcltest -verbose 'start'} { - -constraints {unixOrPc} - -body { - set result [slave msg test.tcl -verbose start] - list $result $msg - } - -result {^0 .*a-1.0 start.*b-1.0 start} - -match regexp -} - -test tcltest-2.7 {tcltest::verbose} { - -body { - set oldVerbosity [verbose] - verbose bar - set currentVerbosity [verbose] - verbose foo - set newVerbosity [verbose] - verbose $oldVerbosity - list $currentVerbosity $newVerbosity - } - -result {body {}} -} - -test tcltest-2.8 {tcltest -verbose 'error'} { - -constraints {unixOrPc} - -body { - 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*'} {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*'} {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*'} {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*'} {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} - -test tcltest-3.5 {tcltest::match} { - -body { - set oldMatch [match] - match foo - set currentMatch [match] - match bar - set newMatch [match] - match $oldMatch - list $currentMatch $newMatch - } - -result {foo bar} -} - -# -skip, [skip] -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*'} {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*'} {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*'} {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*'} {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} - -test tcltest-4.6 {tcltest::skip} { - -body { - set oldSkip [skip] - skip foo - set currentSkip [skip] - skip bar - set newSkip [skip] - skip $oldSkip - list $currentSkip $newSkip - } - -result {foo bar} -} - -# -constraints, -limitconstraints, [testConstraint], -# $constraintsSpecified, [limitConstraints] -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} {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} - -test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)} { - -body { - set r1 [testConstraint tcltestFakeConstraint] - set r2 [testConstraint tcltestFakeConstraint 4] - set r3 [testConstraint tcltestFakeConstraint] - list $r1 $r2 $r3 - } - -result {0 4 4} - -cleanup {unset ::tcltest::testConstraints(tcltestFakeConstraint)} -} - -# Removed this test of internals of tcltest. Those internals have changed. -#test tcltest-5.4 {tcltest::constraintsSpecified} { -# -setup { -# set constraintlist $::tcltest::constraintsSpecified -# set ::tcltest::constraintsSpecified {} -# } -# -body { -# set r1 $::tcltest::constraintsSpecified -# testConstraint tcltestFakeConstraint1 1 -# set r2 $::tcltest::constraintsSpecified -# testConstraint tcltestFakeConstraint2 1 -# set r3 $::tcltest::constraintsSpecified -# list $r1 $r2 $r3 -# } -# -result {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}} -# -cleanup { -# set ::tcltest::constraintsSpecified $constraintlist -# unset ::tcltest::testConstraints(tcltestFakeConstraint1) -# unset ::tcltest::testConstraints(tcltestFakeConstraint2) -# } -#} - -test tcltest-5.5 {InitConstraints: list of built-in constraints} \ - -constraints {!singleTestInterp} \ - -setup {tcltest::InitConstraints} \ - -body { lsort [array names ::tcltest::testConstraints] } \ - -result [lsort { - 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 -# in agreement with the documentation. [limitConstraints] is supposed -# to take an optional boolean argument, and "knownBug" ain't no boolean! -#test tcltest-5.6 {tcltest::limitConstraints} { -# -setup { -# set keeplc $::tcltest::limitConstraints -# set keepkb [testConstraint knownBug] -# } -# -body { -# set r1 [limitConstraints] -# set r2 [limitConstraints knownBug] -# set r3 [limitConstraints] -# list $r1 $r2 $r3 -# } -# -cleanup { -# limitConstraints $keeplc -# testConstraint knownBug $keepkb -# } -# -result {false knownBug knownBug} -#} - -# -outfile, -errfile, [outputChannel], [outputFile], [errorChannel], [errorFile] -set printerror [makeFile { - package require tcltest - namespace import ::tcltest::* - puts [outputChannel] "a test" - ::tcltest::PrintError "a really short string" - ::tcltest::PrintError "a really really really really really really long \ - string containing \"quotes\" and other bad bad stuff" - ::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\"" - ::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 unixOrPc - -body { - slave msg $printerror - return $msg - } - -result {a test.*a really} - -match regexp -} -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] -} {0 1 0 1 1 {}} -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} {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] \ - $result1 $result2 \ - [file exists a.tmp] [file delete a.tmp] \ - [file exists b.tmp] [file delete b.tmp] -} {0 0 0 0 1 {} 1 {}} - -test tcltest-6.5 {tcltest::errorChannel - retrieval} { - -setup { - set of [errorChannel] - set ::tcltest::errorChannel stderr - } - -body { - errorChannel - } - -result {stderr} - -cleanup { - set ::tcltest::errorChannel $of - } -} - -test tcltest-6.6 {tcltest::errorFile (implicit errorChannel)} { - -setup { - set ef [makeFile {} efile] - set of [errorFile] - set ::tcltest::errorChannel stderr - set ::tcltest::errorFile stderr - } - -body { - set f0 [errorChannel] - set f1 [errorFile] - set f2 [errorFile $ef] - set f3 [errorChannel] - set f4 [errorFile] - subst {$f0;$f1;$f2;$f3;$f4} - } - -result {stderr;stderr;.*efile;file[0-9a-f]+;.*efile} - -match regexp - -cleanup { - errorFile $of - removeFile efile - } -} -test tcltest-6.7 {tcltest::outputChannel - retrieval} { - -setup { - set of [outputChannel] - set ::tcltest::outputChannel stdout - } - -body { - outputChannel - } - -result {stdout} - -cleanup { - set ::tcltest::outputChannel $of - } -} - -test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} { - -setup { - set ef [makeFile {} efile] - set of [outputFile] - set ::tcltest::outputChannel stdout - set ::tcltest::outputFile stdout - } - -body { - set f0 [outputChannel] - set f1 [outputFile] - set f2 [outputFile $ef] - set f3 [outputChannel] - set f4 [outputFile] - subst {$f0;$f1;$f2;$f3;$f4} - } - -result {stdout;stdout;.*efile;file[0-9a-f]+;.*efile} - -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 -} {0} -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} {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} {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} {unixOrPc} { - catch {exec [interpreter] test.tcl -debug 3} msg - list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg] -} {1 1} - -test tcltest-7.6 {tcltest::debug} { - -setup { - set old $::tcltest::debug - set ::tcltest::debug 0 - } - -body { - set f1 [debug] - set f2 [debug 1] - set f3 [debug] - set f4 [debug 2] - set f5 [debug] - list $f1 $f2 $f3 $f4 $f5 - } - -result {0 1 1 2 2} - -cleanup { - set ::tcltest::debug $old - } -} -removeFile test.tcl - -# directory tests - -set a [makeFile { - package require tcltest - tcltest::makeFile {} a.tmp - puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]" - exit -} a.tcl] - -set tdiaf [makeFile {} thisdirectoryisafile] - -set normaldirectory [makeDirectory normaldirectory] -normalizePath normaldirectory - -# -tmpdir, [temporaryDirectory] -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 -} -result 1 -test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} { - -constraints unixOrPc - -body { - 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 { - file attributes $notReadableDir -permissions 00333 - file attributes $notWriteableDir -permissions 00555 - } - default { - catch {file attributes $notWriteableDir -readonly 1} - catch {testchmod 0 $notWriteableDir} - } -} -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 - set ::tcltest::temporaryDirectory $normaldirectory - } - -body { - set f1 [temporaryDirectory] - set f2 [temporaryDirectory [workingDirectory]] - set f3 [temporaryDirectory] - list $f1 $f2 $f3 - } - -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 [workingDirectory]] - set f3 [temporaryDirectory] - list $f1 $f2 $f3 -} -cleanup { - set ::tcltest::temporaryDirectory $old -} -result [list $normaldirectory [workingDirectory] [workingDirectory]] -cd [temporaryDirectory] -# -testdir, [testsDirectory] -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 ::tcltest::testsDirectory $normaldirectory - } - -body { - set f1 [testsDirectory] - set f2 [testsDirectory $current] - set f3 [testsDirectory] - list $f1 $f2 $f3 - } - -result "[list $normaldirectory $current $current]" - -cleanup { - set ::tcltest::testsDirectory $old - } -} -# [workingDirectory] -test tcltest-8.60 {::workingDirectory} { - -setup { - set old $::tcltest::workingDirectory - set current [pwd] - set ::tcltest::workingDirectory $normaldirectory - cd $normaldirectory - } - -body { - set f1 [workingDirectory] - set f2 [pwd] - set f3 [workingDirectory $current] - set f4 [pwd] - set f5 [workingDirectory] - list $f1 $f2 $f3 $f4 $f5 - } - -result "[list $normaldirectory \ - $normaldirectory \ - $current \ - $current \ - $current]" - -cleanup { - set ::tcltest::workingDirectory $old - cd $current - } -} - -# clean up from directory testing - -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 -removeFile a.tcl -removeFile thisdirectoryisafile -removeDirectory normaldirectory - -# -file, -notfile, [matchFiles], [skipFiles] -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 { - set old [matchFiles] - matchFiles foo - set current [matchFiles] - matchFiles bar - set new [matchFiles] - matchFiles $old - list $current $new - } - -result {foo bar} -} - -test tcltest-9.4 {skipFiles} { - -body { - set old [skipFiles] - skipFiles foo - set current [skipFiles] - skipFiles bar - set new [skipFiles] - skipFiles $old - list $current $new - } - -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 - namespace import ::tcltest::test - test makecore {make a core file} { - set f [open core w] - close $f - } {} - ::tcltest::cleanupTests - return -} makecore.tcl] - -cd [temporaryDirectory] -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} {unixOrPc} { - slave msg $mc -preservecore 1 - file delete core - regexp "Core file produced" $msg -} {1} -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} {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] -} {1 1 1 {}} - -# 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 tcltest's operation. -#test tcltest-10.5 {preserveCore} { -# -body { -# set old [preserveCore] -# set result [preserveCore foo] -# set result2 [preserveCore] -# preserveCore $old -# list $result $result2 -# } -# -result {foo foo} -#} -removeFile makecore.tcl - -# -load, -loadfile, [loadScript], [loadFile] -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 - return $msg -} {xxx} - -# Using child process because of -debug usage. -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]]] \ - [regexp {loadScript} [join [list $msg] [split $msg \n]]] -} {1 1} - -test tcltest-12.3 {loadScript} { - -setup { - set old $::tcltest::loadScript - set ::tcltest::loadScript {} - } - -body { - set f1 [loadScript] - set f2 [loadScript xxx] - set f3 [loadScript] - list $f1 $f2 $f3 - } - -result {{} xxx xxx} - -cleanup { - set ::tcltest::loadScript $old - } -} - -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 $loadfile] - set f4 [loadScript] - set f5 [loadFile] - list $f1 $f2 $f3 $f4 $f5 - } - -result "[list {} {} $loadfile $contents $loadfile]\n" - -cleanup { - set ::tcltest::loadScript $olds - set ::tcltest::loadFile $oldf - } -} -removeFile load.tcl - -# [interpreter] -test tcltest-13.1 {interpreter} { - -setup { - set old $::tcltest::tcltest - set ::tcltest::tcltest tcltest - } - -body { - set f1 [interpreter] - set f2 [interpreter tclsh] - set f3 [interpreter] - list $f1 $f2 $f3 - } - -result {tcltest tclsh tclsh} - -cleanup { - set ::tcltest::tcltest $old - } -} - -# -singleproc, [singleProcess] -set spd [makeDirectory singleprocdir] -makeFile { - set foo 1 -} single1.test $spd - -makeFile { - unset foo -} single2.test $spd - -set allfile [makeFile { - package require tcltest - namespace import tcltest::* - testsDirectory [file join [temporaryDirectory] singleprocdir] - runAllTests -} all-single.tcl $spd] -cd [workingDirectory] - -test tcltest-14.1 {-singleproc - single process} { - -constraints {unixOrPc} - -body { - slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory] - return $msg - } - -result {Test file error: can't unset .foo.: no such variable} - -match regexp -} - -test tcltest-14.2 {-singleproc - multiple process} { - -constraints {unixOrPc} - -body { - 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 -} - -test tcltest-14.3 {singleProcess} { - -setup { - set old $::tcltest::singleProcess - set ::tcltest::singleProcess 0 - } - -body { - set f1 [singleProcess] - set f2 [singleProcess 1] - set f3 [singleProcess] - list $f1 $f2 $f3 - } - -result {0 1 1} - -cleanup { - 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. - -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 -} all.tcl $dtd -makeFile { - package require tcltest - namespace import -force tcltest::* - testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.1] - runAllTests -} all.tcl $dtd1 -makeFile { - package require tcltest - namespace import -force tcltest::* - testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.2] - runAllTests -} all.tcl $dtd2 -makeFile { - 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 {unixOrPc} - -body { - 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.[123].*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123]} -} - -test tcltest-15.2 {-asidefromdir} { - -constraints {unixOrPc} - -body { - 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.[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!$} -} - -test tcltest-15.3 {-relateddir, non-existent dir} { - -constraints {unixOrPc} - -body { - if {[slave msg \ - [file join $dtd all.tcl] \ - -relateddir [file join [temporaryDirectory] dirtestdir0] \ - -tmpdir [temporaryDirectory]] == 1} { - error $msg - } - } - -returnCodes 1 - -match regexp - -result {[^~]|dirtestdir[^2]} -} - -test tcltest-15.4 {-relateddir, subdir} { - -constraints {unixOrPc} - -body { - if {[slave msg \ - [file join $dtd all.tcl] \ - -relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} { - error $msg - } - } - -returnCodes 1 - -match regexp - -result {Tests located in:.*dirtestdir2.[^23]} -} -test tcltest-15.5 {-relateddir, -asidefromdir} { - -constraints {unixOrPc} - -body { - if {[slave msg \ - [file join $dtd all.tcl] \ - -relateddir "dirtestdir2.1 dirtestdir2.2" \ - -asidefromdir dirtestdir2.2 \ - -tmpdir [temporaryDirectory]] == 1} { - error $msg - } - } - -match regexp - -returnCodes 1 - -result {Tests located in:.*dirtestdir2.[^23]} -} - -test tcltest-15.6 {matchDirectories} { - -setup { - set old [matchDirectories] - set ::tcltest::matchDirectories {} - } - -body { - set r1 [matchDirectories] - set r2 [matchDirectories foo] - set r3 [matchDirectories] - list $r1 $r2 $r3 - } - -cleanup { - set ::tcltest::matchDirectories $old - } - -result {{} foo foo} -} - -test tcltest-15.7 {skipDirectories} { - -setup { - set old [skipDirectories] - set ::tcltest::skipDirectories {} - } - -body { - set r1 [skipDirectories] - set r2 [skipDirectories foo] - set r3 [skipDirectories] - list $r1 $r2 $r3 - } - -cleanup { - set ::tcltest::skipDirectories $old - } - -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} -setup { - if {[info exists ::env(TCLTEST_OPTIONS)]} { - set oldoptions $::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) { } - 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 - } - } -body { - slave1 eval [package ifneeded tcltest [package provide tcltest]] - slave1 eval tcltest::debug - set ::env(TCLTEST_OPTIONS) "-debug 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 [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 { - set v [verbose] -} -cleanup { - verbose $v -} -body { - verbose {} - test tcltest-21.0.0 bar -} -result {} - -test tcltest-21.1 {expect with glob} { - -body { - list a b c d e - } - -match glob - -result {[ab] b c d e} -} - -test tcltest-21.2 {force a test command failure} { - -body { - test tcltest-21.2.0 { - return 2 - } {1} - } - -returnCodes 1 - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} -} - -test tcltest-21.3 {test command with setup} { - -setup { - set foo 1 - } - -body { - set foo - } - -cleanup {unset foo} - -result {1} -} - -test tcltest-21.4 {test command with cleanup failure} { - -setup { - if {[info exists foo]} { - unset foo - } - set fail $::tcltest::currentFailure - set v [verbose] - } - -body { - verbose {} - test tcltest-21.4.0 {foo-1} { - -cleanup {unset foo} - } - } - -result {^$} - -match regexp - -cleanup {verbose $v; set ::tcltest::currentFailure $fail} - -output "Test cleanup failed:.*can't unset \"foo\": no such variable" -} - -test tcltest-21.5 {test command with setup failure} { - -setup { - if {[info exists foo]} { - unset foo - } - set fail $::tcltest::currentFailure - } - -body { - test tcltest-21.5.0 {foo-2} { - -setup {unset foo} - } - } - -result {^$} - -match regexp - -cleanup {set ::tcltest::currentFailure $fail} - -output "Test setup failed:.*can't unset \"foo\": no such variable" -} - -test tcltest-21.6 {test command - setup occurs before cleanup & before script} { - -setup {set v [verbose]; set fail $::tcltest::currentFailure} - -body { - verbose {} - test tcltest-21.6.0 {foo-3} { - -setup { - if {[info exists foo]} { - unset foo - } - set foo 1 - set expected 2 - } - -body { - incr foo - set foo - } - -cleanup { - if {$foo != 2} { - puts [outputChannel] "foo is wrong" - } else { - puts [outputChannel] "foo is 2" - } - } - -result {$expected} - } - } - -cleanup {verbose $v; set ::tcltest::currentFailure $fail} - -result {^$} - -match regexp - -output "foo is 2" -} - -test tcltest-21.7 {test command - bad flag} { - -setup {set fail $::tcltest::currentFailure} - -cleanup {set ::tcltest::currentFailure $fail} - -body { - test tcltest-21.7.0 {foo-4} { - -foobar {} - } - } - -returnCodes 1 - -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 -# exception of being in the all-inline format) - -test tcltest-21.7a {expect with glob} \ - -body {list a b c d e} \ - -result {[ab] b c d e} \ - -match glob - -test tcltest-21.8 {force a test command failure} \ - -setup {set fail $::tcltest::currentFailure} \ - -body { - test tcltest-21.8.0 { - return 2 - } {1} - } \ - -returnCodes 1 \ - -cleanup {set ::tcltest::currentFailure $fail} \ - -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} \ - -body {set foo} \ - -cleanup {unset foo} \ - -result {1} - -test tcltest-21.10 {test command with cleanup failure} -setup { - if {[info exists foo]} { - unset foo - } - set fail $::tcltest::currentFailure - set v [verbose] -} -cleanup { - verbose $v - set ::tcltest::currentFailure $fail -} -body { - verbose {} - test tcltest-21.10.0 {foo-1} -cleanup {unset foo} -} -result {^$} -match regexp \ - -output {Test cleanup failed:.*can't unset \"foo\": no such variable} - -test tcltest-21.11 {test command with setup failure} -setup { - if {[info exists foo]} { - unset foo - } - set fail $::tcltest::currentFailure -} -cleanup {set ::tcltest::currentFailure $fail} -body { - test tcltest-21.11.0 {foo-2} -setup {unset foo} -} -result {^$} -output {Test setup failed:.*can't unset \"foo\": no such variable} -match regexp - -test tcltest-21.12 { - test command - setup occurs before cleanup & before script -} -setup { - set fail $::tcltest::currentFailure - set v [verbose] -} -cleanup { - verbose $v - set ::tcltest::currentFailure $fail -} -body { - verbose {} - test tcltest-21.12.0 {foo-3} -setup { - if {[info exists foo]} { - unset foo - } - set foo 1 - set expected 2 - } -body { - incr foo - set foo - } -cleanup { - if {$foo != 2} { - puts [outputChannel] "foo is wrong" - } else { - puts [outputChannel] "foo is 2" - } - } -result {$expected} -} -result {^$} -output {foo is 2} -match regexp - -# test all.tcl usage (runAllTests); simulate .test file failure, as well as -# crashes to determine whether or not these errors are logged. - -set atd [makeDirectory alltestdir] -makeFile { - package require tcltest - namespace import -force tcltest::* - testsDirectory [file join [temporaryDirectory] alltestdir] - runAllTests -} all.tcl $atd -makeFile { - exit 1 -} exit.test $atd -makeFile { - error "throw an error" -} error.test $atd -makeFile { - package require tcltest - namespace import -force tcltest::* - test foo-1.1 {foo} { - -body { return 1 } - -result {1} - } - cleanupTests -} 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 $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} { - -setup { - set mfdir [file join [temporaryDirectory] mfdir] - file mkdir $mfdir - } - -body { - makeFile {} t1.tmp - makeFile {} et1.tmp $mfdir - list [file exists [file join [temporaryDirectory] t1.tmp]] \ - [file exists [file join $mfdir et1.tmp]] - } - -cleanup { - file delete -force $mfdir \ - [file join [temporaryDirectory] t1.tmp] - } - -result {1 1} -} -test tcltest-23.2 {removeFile} { - -setup { - set mfdir [file join [temporaryDirectory] mfdir] - file mkdir $mfdir - makeFile {} t1.tmp - makeFile {} et1.tmp $mfdir - if {![file exists [file join [temporaryDirectory] t1.tmp]] || \ - ![file exists [file join $mfdir et1.tmp]]} { - error "file creation didn't work" - } - } - -body { - removeFile t1.tmp - removeFile et1.tmp $mfdir - list [file exists [file join [temporaryDirectory] t1.tmp]] \ - [file exists [file join $mfdir et1.tmp]] - } - -cleanup { - file delete -force $mfdir \ - [file join [temporaryDirectory] t1.tmp] - } - -result {0 0} -} -test tcltest-23.3 {makeDirectory} { - -body { - set mfdir [file join [temporaryDirectory] mfdir] - file mkdir $mfdir - makeDirectory d1 - makeDirectory d2 $mfdir - list [file exists [file join [temporaryDirectory] d1]] \ - [file exists [file join $mfdir d2]] - } - -cleanup { - file delete -force [file join [temporaryDirectory] d1] $mfdir - } - -result {1 1} -} -test tcltest-23.4 {removeDirectory} { - -setup { - set mfdir [makeDirectory mfdir] - makeDirectory t1 - makeDirectory t2 $mfdir - if {![file exists $mfdir] || \ - ![file exists [file join [temporaryDirectory] $mfdir t2]]} { - error "setup failed - directory not created" - } - } - -body { - removeDirectory t1 - removeDirectory t2 $mfdir - list [file exists [file join [temporaryDirectory] t1]] \ - [file exists [file join $mfdir t2]] - } - -result {0 0} -} -test tcltest-23.5 {viewFile} { - -body { - set mfdir [file join [temporaryDirectory] mfdir] - file mkdir $mfdir - makeFile {foobar} t1.tmp - makeFile {foobarbaz} t2.tmp $mfdir - list [viewFile t1.tmp] [viewFile t2.tmp $mfdir] - } - -result {foobar foobarbaz} - -cleanup { - file delete -force $mfdir - removeFile t1.tmp - } -} - -# customMatch -proc matchNegative { expected actual } { - set match 0 - foreach a $actual e $expected { - if { $a != $e } { - set match 1 - break - } - } - return $match -} - -test tcltest-24.0 { - customMatch: syntax -} -body { - list [catch {customMatch} result] $result -} -result [list 1 "wrong # args: should be \"customMatch mode script\""] - -test tcltest-24.1 { - customMatch: syntax -} -body { - list [catch {customMatch foo} result] $result -} -result [list 1 "wrong # args: should be \"customMatch mode script\""] - -test tcltest-24.2 { - customMatch: syntax -} -body { - list [catch {customMatch foo bar baz} result] $result -} -result [list 1 "wrong # args: should be \"customMatch mode script\""] - -test tcltest-24.3 { - customMatch: argument checking -} -body { - list [catch {customMatch bad "a \{ b"} result] $result -} -result [list 1 "invalid customMatch script; can't evaluate after completion"] - -test tcltest-24.4 { - test: valid -match values -} -body { - list [catch { - test tcltest-24.4.0 {} \ - -match [namespace current]::noSuchMode - } result] $result -} -match glob -result {1 *bad -match value*} - -test tcltest-24.5 { - test: valid -match values -} -setup { - customMatch [namespace current]::alwaysMatch "format 1 ;#" -} -body { - list [catch { - test tcltest-24.5.0 {} \ - -match [namespace current]::noSuchMode - } result] $result -} -match glob -result {1 *bad -match value*: must be *alwaysMatch,*} - -test tcltest-24.6 { - customMatch: -match script that always matches -} -setup { - customMatch [namespace current]::alwaysMatch "format 1 ;#" - set v [verbose] -} -body { - verbose {} - test tcltest-24.6.0 {} -match [namespace current]::alwaysMatch \ - -body {format 1} -result 0 -} -cleanup { - verbose $v -} -result {} -output {} -errorOutput {} - -test tcltest-24.7 { - customMatch: replace default -exact matching -} -setup { - set saveExactMatchScript $::tcltest::CustomMatch(exact) - customMatch exact "format 1 ;#" - set v [verbose] -} -body { - verbose {} - test tcltest-24.7.0 {} -body {format 1} -result 0 -} -cleanup { - verbose $v - customMatch exact $saveExactMatchScript - unset saveExactMatchScript -} -result {} -output {} - -test tcltest-24.9 { - customMatch: error during match -} -setup { - proc errorDuringMatch args {return -code error "match returned error"} - customMatch [namespace current]::errorDuringMatch \ - [namespace code errorDuringMatch] - set v [verbose] - set fail $::tcltest::currentFailure -} -body { - verbose {} - test tcltest-24.9.0 {} -match [namespace current]::errorDuringMatch -} -cleanup { - verbose $v - set ::tcltest::currentFailure $fail -} -match glob -result {} -output {*FAILED*match returned error*} - -test tcltest-24.10 { - customMatch: bad return from match command -} -setup { - proc nonBooleanReturn args {return foo} - customMatch nonBooleanReturn [namespace code nonBooleanReturn] - set v [verbose] - set fail $::tcltest::currentFailure -} -body { - verbose {} - test tcltest-24.10.0 {} -match nonBooleanReturn -} -cleanup { - verbose $v - set ::tcltest::currentFailure $fail -} -match glob -result {} -output {*FAILED*expected boolean value*} - -test tcltest-24.11 { - test: -match exact -} -body { - set result {A B C} -} -match exact -result {A B C} - -test tcltest-24.12 { - test: -match exact match command eval in ::, not caller namespace -} -setup { - set saveExactMatchScript $::tcltest::CustomMatch(exact) - customMatch exact [list string equal] - set v [verbose] - proc string args {error {called [string] in caller namespace}} -} -body { - verbose {} - test tcltest-24.12.0 {} -body {format 1} -result 1 -} -cleanup { - rename string {} - verbose $v - customMatch exact $saveExactMatchScript - unset saveExactMatchScript -} -match exact -result {} -output {} - -test tcltest-24.13 { - test: -match exact failure -} -setup { - set saveExactMatchScript $::tcltest::CustomMatch(exact) - customMatch exact [list string equal] - set v [verbose] - set fail $::tcltest::currentFailure -} -body { - verbose {} - test tcltest-24.13.0 {} -body {format 1} -result 0 -} -cleanup { - set ::tcltest::currentFailure $fail - verbose $v - customMatch exact $saveExactMatchScript - unset saveExactMatchScript -} -match glob -result {} -output {*FAILED*Result was: -1*(exact matching): -0*} - -test tcltest-24.14 { - test: -match glob -} -body { - set result {A B C} -} -match glob -result {A B*} - -test tcltest-24.15 { - test: -match glob failure -} -setup { - set v [verbose] - set fail $::tcltest::currentFailure -} -body { - verbose {} - test tcltest-24.15.0 {} -match glob -body {format {A B C}} \ - -result {A B* } -} -cleanup { - set ::tcltest::currentFailure $fail - verbose $v -} -match glob -result {} -output {*FAILED*Result was: -*(glob matching): -*} - -test tcltest-24.16 { - test: -match regexp -} -body { - set result {A B C} -} -match regexp -result {A B.*} - -test tcltest-24.17 { - test: -match regexp failure -} -setup { - set fail $::tcltest::currentFailure - set v [verbose] -} -body { - verbose {} - test tcltest-24.17.0 {} -match regexp -body {format {A B C}} \ - -result {A B.* X} -} -cleanup { - set ::tcltest::currentFailure $fail - verbose $v -} -match glob -result {} -output {*FAILED*Result was: -*(regexp matching): -*} - -test tcltest-24.18 { - test: -match custom forget namespace qualification -} -setup { - set fail $::tcltest::currentFailure - set v [verbose] - customMatch negative matchNegative -} -body { - verbose {} - test tcltest-24.18.0 {} -match negative -body {format {A B C}} \ - -result {A B X} -} -cleanup { - set ::tcltest::currentFailure $fail - verbose $v -} -match glob -result {} -output {*FAILED*Error testing result:*} - -test tcltest-24.19 { - test: -match custom -} -setup { - set v [verbose] - customMatch negative [namespace code matchNegative] -} -body { - verbose {} - test tcltest-24.19.0 {} -match negative -body {format {A B C}} \ - -result {A B X} -} -cleanup { - verbose $v -} -match exact -result {} -output {} - -test tcltest-24.20 { - test: -match custom failure -} -setup { - set fail $::tcltest::currentFailure - set v [verbose] - customMatch negative [namespace code matchNegative] -} -body { - verbose {} - test tcltest-24.20.0 {} -match negative -body {format {A B C}} \ - -result {A B C} -} -cleanup { - set ::tcltest::currentFailure $fail - verbose $v -} -match glob -result {} -output {*FAILED*Result was: -*(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 -} - -namespace delete ::tcltest::test -return - -# Local Variables: -# mode: tcl -# End: |