diff -r 000000000000 -r bde4ae8d615e os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/tcltest.test
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/tcltest.test Fri Jun 15 03:10:57 2012 +0200
@@ -0,0 +1,1804 @@
+# 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.
+#
+# RCS: @(#) $Id: tcltest.test,v 1.37.2.11 2006/03/19 22:47:30 vincentdarley Exp $
+
+# 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}} foo]
+if $code {
+#puts "$code: $foo\n$::errorInfo"
+}
+ 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
+
+# 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]
+ 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} {unixOrPc} {
+ file delete -force thisdirectorydoesnotexist
+ slave msg $a -tmpdir thisdirectorydoesnotexist
+ list [file exists [file join thisdirectorydoesnotexist a.tmp]] \
+ [file delete -force thisdirectorydoesnotexist]
+} {1 {}}
+test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {
+ -constraints unixOrPc
+ -body {
+ slave msg $a -tmpdir $tdiaf
+ set 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 000 $notWriteableDir}
+ }
+}
+
+test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {unix notRoot} {
+ slave msg $a -tmpdir $notReadableDir
+ string match {*not readable*} $msg
+} {1}
+
+test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {unixOrPc notRoot} {
+ slave msg $a -tmpdir $notWriteableDir
+ string match {*not writeable*} $msg
+} {1}
+
+test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {unixOrPc} {
+ slave msg $a -tmpdir $normaldirectory
+ # The join is necessary because the message can be split on multiple lines
+ list [file exists [file join $normaldirectory a.tmp]] \
+ [file delete [file join $normaldirectory a.tmp]]
+} {1 {}}
+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} {unixOrPc} {
+ file delete -force thisdirectorydoesnotexist
+ slave msg $a -testdir thisdirectorydoesnotexist
+ string match "*does not exist*" $msg
+} {1}
+
+test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {unixOrPc} {
+ slave msg $a -testdir $tdiaf
+ string match "*not a directory*" $msg
+} {1}
+
+test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {unix notRoot} {
+ slave msg $a -testdir $notReadableDir
+ string match {*not readable*} $msg
+} {1}
+
+
+test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {unixOrPc} {
+ slave msg $a -testdir $normaldirectory
+ # The join is necessary because the message can be split on multiple lines
+ list [string first "testdir: $normaldirectory" [join $msg]] \
+ [file exists [file join [temporaryDirectory] a.tmp]] \
+ [file delete [file join [temporaryDirectory] a.tmp]]
+} {0 1 {}}
+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 {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
+ set 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
+ set 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]
+ set 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]
+ set 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 == "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]
+ set 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]
+ set msg
+} -cleanup {
+ removeFile test.tcl
+} -match glob -result {*
+---- errorInfo: body error
+*
+---- errorInfo(cleanup): cleanup error*}
+
+cleanupTests
+}
+
+namespace delete ::tcltest::test
+return