diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/cmdAH.test | 24 | ||||
| -rwxr-xr-x | tests/tcltest.test | 172 |
2 files changed, 112 insertions, 84 deletions
diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 3f12dd2..031d152 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdAH.test,v 1.54 2006/10/01 13:03:56 patthoyts Exp $ +# RCS: @(#) $Id: cmdAH.test,v 1.55 2007/01/18 22:09:44 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -1161,16 +1161,13 @@ test cmdAH-24.4 {Tcl_FileObjCmd: mtime} { test cmdAH-24.5 {Tcl_FileObjCmd: mtime} { # Under Unix, use a file in /tmp to avoid clock skew due to NFS. # On other platforms, just use a file in the local directory. - if {[testConstraint unix]} { set name /tmp/tcl.test.[pid] } else { set name [file join [temporaryDirectory] tf] } - # Make sure that a new file's time is correct. 10 seconds variance # is allowed used due to slow networks or clock skew on a network drive. - file delete -force $name close [open $name w] set a [expr abs([clock seconds]-[file mtime $name])<10] @@ -1230,7 +1227,6 @@ test cmdAH-24.11 {Tcl_FileObjCmd: mtime touch with non-ascii chars} win { } 1 removeFile touch.me rename waitForEvenSecondForFAT {} - test cmdAH-24.12 {Tcl_FileObjCmd: mtime and daylight savings} { set name [file join [temporaryDirectory] clockchange] file delete -force $name @@ -1241,21 +1237,19 @@ test cmdAH-24.12 {Tcl_FileObjCmd: mtime and daylight savings} { file delete $name expr {$newmtime == $time ? 1 : "$newmtime != $time"} } {1} - # bug 1420432: setting mtime fails for directories on windows. -test cmdAH-24.13 {Tcl_FileObjCmd: directory mtime} { +test cmdAH-24.13 {Tcl_FileObjCmd: directory mtime} -setup { set dirname [file join [temporaryDirectory] tmp[pid]] file delete -force $dirname +} -constraints tempNotWin -body { file mkdir $dirname - set res [catch { - set old [file mtime $dirname] - file mtime $dirname 0 - set new [file mtime $dirname] - list $new [expr {$old != $new}] - } err] + set old [file mtime $dirname] + file mtime $dirname 0 + set new [file mtime $dirname] + list $new [expr {$old != $new}] +} -cleanup { file delete -force $dirname - list $res $err -} {0 {0 1}} +} -result {0 1} # owned 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 {* |