summaryrefslogtreecommitdiffstats
path: root/tests/tcltest.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/tcltest.test')
-rwxr-xr-xtests/tcltest.test172
1 files changed, 103 insertions, 69 deletions
diff --git a/tests/tcltest.test b/tests/tcltest.test
index 421a777..637612d 100755
--- a/tests/tcltest.test
+++ b/tests/tcltest.test
@@ -2,13 +2,13 @@
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
-# RCS: @(#) $Id: tcltest.test,v 1.54 2006/10/09 19:15:45 msofer Exp $
+# RCS: @(#) $Id: tcltest.test,v 1.55 2007/01/18 22:09:44 dkf Exp $
-# Note that there are several places where the value of
+# Note that there are several places where the value of
# tcltest::currentFailure is stored/reset in the -setup/-cleanup
# of a test that has a body that runs [test] that will fail.
# This is a workaround of using the same tcltest code that we are
@@ -16,7 +16,7 @@
#
# It would be better to have the -body of the tests run the tcltest
# commands in a slave interp so the [test] being tested would not
-# interfere with the [test] doing the testing.
+# interfere with the [test] doing the testing.
#
if {[catch {package require tcltest 2.1}]} {
@@ -53,7 +53,7 @@ testConstraint exec [llength [info commands exec]]
test tcltest-1.1 {tcltest -help} {exec} {
set result [catch {exec [interpreter] test.tcl -help} msg]
list $result [regexp Usage $msg]
-} {1 1}
+} {1 1}
test tcltest-1.2 {tcltest -help -something} {exec} {
set result [catch {exec [interpreter] test.tcl -help -something} msg]
list $result [regexp Usage $msg]
@@ -61,7 +61,7 @@ test tcltest-1.2 {tcltest -help -something} {exec} {
test tcltest-1.3 {tcltest -h} {exec} {
set result [catch {exec [interpreter] test.tcl -h} msg]
list $result [regexp Usage $msg]
-} {1 0}
+} {1 0}
# -verbose, implicit & explicit testing of [verbose]
proc slave {msgVar args} {
@@ -528,29 +528,28 @@ set normaldirectory [makeDirectory normaldirectory]
normalizePath normaldirectory
# -tmpdir, [temporaryDirectory]
-test tcltest-8.1 {tcltest a.tcl -tmpdir a} {unixOrPc} {
+test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrPc -setup {
file delete -force thisdirectorydoesnotexist
+} -body {
slave msg $a -tmpdir thisdirectorydoesnotexist
- list [file exists [file join thisdirectorydoesnotexist a.tmp]] \
- [file delete -force thisdirectorydoesnotexist]
-} {1 {}}
+ file exists [file join thisdirectorydoesnotexist a.tmp]
+} -cleanup {
+ file delete -force thisdirectorydoesnotexist
+} -result 1
test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {
-constraints unixOrPc
-body {
slave msg $a -tmpdir $tdiaf
- set msg
+ return $msg
}
-result {*not a directory*}
-match glob
}
-
# Test non-writeable directories, non-readable directories with directory flags
set notReadableDir [file join [temporaryDirectory] notreadable]
set notWriteableDir [file join [temporaryDirectory] notwriteable]
-
makeDirectory notreadable
makeDirectory notwriteable
-
switch -- $::tcl_platform(platform) {
"unix" {
file attributes $notReadableDir -permissions 00333
@@ -561,25 +560,44 @@ switch -- $::tcl_platform(platform) {
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 {}}
+test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {
+ -constraints {unix notRoot}
+ -body {
+ slave msg $a -tmpdir $notReadableDir
+ return $msg
+ }
+ -result {*not readable*}
+ -match glob
+}
+# This constraint doesn't go at the top of the file so that it doesn't
+# interfere with tcltest-5.5
+testConstraint notFAT [expr {
+ ![string match "FAT*" [lindex [file system $notWriteableDir] 1]]
+}]
+# FAT permissions are fairly hopeless; ignore this test if that FS is used
+test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {
+ -constraints {unixOrPc notRoot notFAT}
+ -body {
+ slave msg $a -tmpdir $notWriteableDir
+ return $msg
+ }
+ -result {*not writeable*}
+ -match glob
+}
+test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {
+ -constraints unixOrPc
+ -body {
+ slave msg $a -tmpdir $normaldirectory
+ # The join is necessary because the message can be split on multiple
+ # lines
+ file exists [file join $normaldirectory a.tmp]
+ }
+ -cleanup {
+ catch {file delete [file join $normaldirectory a.tmp]}
+ }
+ -result 1
+}
cd [workingDirectory]
-
test tcltest-8.6 {temporaryDirectory} {
-setup {
set old $::tcltest::temporaryDirectory
@@ -596,7 +614,6 @@ test tcltest-8.6 {temporaryDirectory} {
set ::tcltest::temporaryDirectory $old
}
}
-
test tcltest-8.6a {temporaryDirectory - test format 2} -setup {
set old $::tcltest::temporaryDirectory
set ::tcltest::temporaryDirectory $normaldirectory
@@ -608,35 +625,53 @@ test tcltest-8.6a {temporaryDirectory - test format 2} -setup {
} -cleanup {
set ::tcltest::temporaryDirectory $old
} -result [list $normaldirectory [workingDirectory] [workingDirectory]]
-
cd [temporaryDirectory]
# -testdir, [testsDirectory]
-test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {unixOrPc} {
- file delete -force thisdirectorydoesnotexist
- slave msg $a -testdir thisdirectorydoesnotexist
- string match "*does not exist*" $msg
-} {1}
-
-test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {unixOrPc} {
- slave msg $a -testdir $tdiaf
- string match "*not a directory*" $msg
-} {1}
-
-test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {unix notRoot} {
- slave msg $a -testdir $notReadableDir
- string match {*not readable*} $msg
-} {1}
-
-
-test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {unixOrPc} {
- slave msg $a -testdir $normaldirectory
- # The join is necessary because the message can be split on multiple lines
- list [string first "testdir: $normaldirectory" [join $msg]] \
- [file exists [file join [temporaryDirectory] a.tmp]] \
- [file delete [file join [temporaryDirectory] a.tmp]]
-} {0 1 {}}
+test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {
+ -constraints unixOrPc
+ -setup {
+ file delete -force thisdirectorydoesnotexist
+ }
+ -body {
+ slave msg $a -testdir thisdirectorydoesnotexist
+ return $msg
+ }
+ -match glob
+ -result {*does not exist*}
+}
+test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {
+ -constraints unixOrPc
+ -body {
+ slave msg $a -testdir $tdiaf
+ return $msg
+ }
+ -match glob
+ -result {*not a directory*}
+}
+test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {
+ -constraints {unix notRoot}
+ -body {
+ slave msg $a -testdir $notReadableDir
+ return $msg
+ }
+ -match glob
+ -result {*not readable*}
+}
+test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {
+ -constraints unixOrPc
+ -body {
+ slave msg $a -testdir $normaldirectory
+ # The join is necessary because the message can be split on multiple
+ # lines
+ list [string first "testdir: $normaldirectory" [join $msg]] \
+ [file exists [file join [temporaryDirectory] a.tmp]]
+ }
+ -cleanup {
+ file delete [file join [temporaryDirectory] a.tmp]
+ }
+ -result {0 1}
+}
cd [workingDirectory]
-
set current [pwd]
test tcltest-8.14 {testsDirectory} {
-setup {
@@ -654,7 +689,6 @@ test tcltest-8.14 {testsDirectory} {
set ::tcltest::testsDirectory $old
}
}
-
# [workingDirectory]
test tcltest-8.60 {::workingDirectory} {
-setup {
@@ -667,7 +701,7 @@ test tcltest-8.60 {::workingDirectory} {
set f1 [workingDirectory]
set f2 [pwd]
set f3 [workingDirectory $current]
- set f4 [pwd]
+ set f4 [pwd]
set f5 [workingDirectory]
list $f1 $f2 $f3 $f4 $f5
}
@@ -705,7 +739,7 @@ test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup {
testsDirectory [file dirname [info script]]
} -body {
slave msg [file join [testsDirectory] all.tcl] -file d*.test
- set msg
+ return $msg
} -cleanup {
testsDirectory $old
} -match regexp -result {dstring\.test}
@@ -814,17 +848,17 @@ test tcltest-10.4 {-preservecore 3} {unixOrPc} {
removeFile makecore.tcl
# -load, -loadfile, [loadScript], [loadFile]
-set contents {
+set contents {
package require tcltest
namespace import tcltest::*
puts [outputChannel] $::tcltest::loadScript
exit
-}
+}
set loadfile [makeFile $contents load.tcl]
test tcltest-12.1 {-load xxx} {unixOrPc} {
slave msg $loadfile -load xxx
- set msg
+ return $msg
} {xxx}
# Using child process because of -debug usage.
@@ -915,7 +949,7 @@ test tcltest-14.1 {-singleproc - single process} {
-constraints {unixOrPc}
-body {
slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory]
- set msg
+ return $msg
}
-result {Test file error: can't unset .foo.: no such variable}
-match regexp
@@ -925,7 +959,7 @@ test tcltest-14.2 {-singleproc - multiple process} {
-constraints {unixOrPc}
-body {
slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory]
- set msg
+ return $msg
}
-result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0}
-match regexp
@@ -1769,7 +1803,7 @@ test tcltest-26.1 {Bug/RFE 1017151} -setup {
} test.tcl
} -body {
slave msg [file join [temporaryDirectory] test.tcl]
- set msg
+ return $msg
} -cleanup {
removeFile test.tcl
} -match glob -result {*
@@ -1789,7 +1823,7 @@ test tcltest-26.2 {Bug/RFE 1017151} -setup {
} test.tcl
} -body {
slave msg [file join [temporaryDirectory] test.tcl]
- set msg
+ return $msg
} -cleanup {
removeFile test.tcl
} -match glob -result {*