diff options
| author | dkf <donal.k.fellows@manchester.ac.uk> | 2006-03-21 11:12:27 (GMT) |
|---|---|---|
| committer | dkf <donal.k.fellows@manchester.ac.uk> | 2006-03-21 11:12:27 (GMT) |
| commit | 86ca5531ac0818f99726ba9ad478e277cd5d6e94 (patch) | |
| tree | cb78904bbef94025a4f19257afc9211ee618e8ce /tests | |
| parent | d4070e928ea23c067c492b5e594d206a76d9b3d5 (diff) | |
| download | tcl-86ca5531ac0818f99726ba9ad478e277cd5d6e94.zip tcl-86ca5531ac0818f99726ba9ad478e277cd5d6e94.tar.gz tcl-86ca5531ac0818f99726ba9ad478e277cd5d6e94.tar.bz2 | |
Use test constraints properly instead of looking in tcl_platform
Consistent method of calling test constraints, and (try to) move constraint
setup to the top of the test file
Diffstat (limited to 'tests')
34 files changed, 322 insertions, 441 deletions
diff --git a/tests/async.test b/tests/async.test index 969208c..014740a 100644 --- a/tests/async.test +++ b/tests/async.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: async.test,v 1.8 2004/05/19 20:15:31 dkf Exp $ +# RCS: @(#) $Id: async.test,v 1.9 2006/03/21 11:12:27 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -19,8 +19,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } testConstraint testasync [llength [info commands testasync]] - -tcltest::testConstraint threaded [expr { +testConstraint threaded [expr { [info exists ::tcl_platform(threaded)] && $::tcl_platform(threaded) }] diff --git a/tests/binary.test b/tests/binary.test index 557e03d..70dc044 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -10,14 +10,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: binary.test,v 1.26 2005/12/02 17:34:03 dgp Exp $ +# RCS: @(#) $Id: binary.test,v 1.27 2006/03/21 11:12:28 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -::tcltest::testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}] -::tcltest::testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}] +testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}] +testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}] test binary-0.1 {DupByteArrayInternalRep} { set hdr [binary format cc 0 0316] diff --git a/tests/clock.test b/tests/clock.test index 6674fe4..d6c44ab 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -11,30 +11,25 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: clock.test,v 1.60 2005/11/28 15:37:19 kennykb Exp $ +# RCS: @(#) $Id: clock.test,v 1.61 2006/03/21 11:12:28 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } -if { $::tcl_platform(platform) eq {windows} } { - if { [catch { package require registry 1.1 }] } { - +if {[testConstraint win]} { + if {[catch {package require registry 1.1}]} { # HIDEOUS KLUDGE: [package require registry 1.1] has failed. # This failure likely means that we're running in Tcl's build # directory instead of the install directory. We recover by # trying to load tclreg*.dll directly. - - if { [catch { - load [lindex \ - [glob -directory \ - [file join \ - [pwd] \ - [file dirname [info nameofexecutable]]] \ - tclReg*.dll] \ - 0] registry - }] } { + + if {[catch { + load [lindex [glob -directory \ + [file join [pwd] [file dirname [info nameofexecutable]]] \ + tclReg*.dll] 0] registry + }]} then { # Still no registry! namespace eval ::tcl::clock [set NoRegistry {}] } @@ -42,9 +37,9 @@ if { $::tcl_platform(platform) eq {windows} } { } package require msgcat 1.4 -::tcltest::testConstraint detroit \ +testConstraint detroit \ [expr {![catch {clock format 0 -timezone :America/Detroit -format %z}]}] -::tcltest::testConstraint y2038 \ +testConstraint y2038 \ [expr {[clock format 2158894800 -format %z -timezone :America/Detroit] eq {-0400}}] # TEST PLAN diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 9185aff..300e217 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -10,22 +10,21 @@ # 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.52 2006/03/20 11:39:03 dkf Exp $ +# RCS: @(#) $Id: cmdAH.test,v 1.53 2006/03/21 11:12:28 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 namespace import -force ::tcltest::* } -tcltest::testConstraint testchmod [llength [info commands testchmod]] -tcltest::testConstraint testsetplatform \ - [llength [info commands testsetplatform]] -tcltest::testConstraint testvolumetype \ - [llength [info commands testvolumetype]] -tcltest::testConstraint linkDirectory [expr \ - {$tcl_platform(platform) ne "windows" || \ - ([string index $tcl_platform(osVersion) 0] >= 5 \ - && ([lindex [file system [temporaryDirectory]] 1] == "NTFS"))}] +testConstraint testchmod [llength [info commands testchmod]] +testConstraint testsetplatform [llength [info commands testsetplatform]] +testConstraint testvolumetype [llength [info commands testvolumetype]] +testConstraint linkDirectory [expr { + ![testConstraint win] || + ([string index $tcl_platform(osVersion) 0] >= 5 + && [lindex [file system [temporaryDirectory]] 1] eq "NTFS") +}] global env set cmdAHwd [pwd] @@ -957,7 +956,7 @@ catch {file attributes $gorpfile -permissions 0765} # atime # avoid problems with non-local filesystems -if {$::tcl_platform(platform) == "unix" && [file exists /tmp]} { +if {[testConstraint unix] && [file exists /tmp]} { set file [makeFile "data" touch.me /tmp] } else { set file [makeFile "data" touch.me] @@ -989,7 +988,7 @@ test cmdAH-20.5 {Tcl_FileObjCmd: atime touch} {unix} { test cmdAH-20.6 {Tcl_FileObjCmd: atime touch} {win testvolumetype} { set old [pwd] cd $::tcltest::temporaryDirectory - if {![string equal "NTFS" [testvolumetype]]} { + if {"NTFS" ne [testvolumetype]} { # Windows FAT doesn't understand atime, but NTFS does # May also fail for Windows on NFS mounted disks cd $old @@ -1003,7 +1002,7 @@ test cmdAH-20.6 {Tcl_FileObjCmd: atime touch} {win testvolumetype} { expr {$newatime == $modatime ? 1 : "$newatime != $modatime"} } 1 -if {$::tcl_platform(platform) == "unix" && [file exists /tmp]} { +if {[testConstraint unix] && [file exists /tmp]} { removeFile touch.me /tmp } else { removeFile touch.me @@ -1103,17 +1102,19 @@ proc waitForEvenSecondForFAT {} { # timings. :^( # This procedure based on work by Helmut Giese - global tcl_platform - if {$tcl_platform(platform) ne "windows"} {return} - if {[lindex [file system [temporaryDirectory]] 1] == "NTFS"} {return} - # Assume non-NTFS means FAT{12,16,32} and hence in need of special help - set start [clock seconds] - while {1} { - set now [clock seconds] - if {$now!=$start && !($now & 1)} { - return + if { + [testConstraint win] + && [lindex [file system [temporaryDirectory]] 1] ne "NTFS" + } then { + # Assume non-NTFS means FAT{12,16,32} and hence in need of special help + set start [clock seconds] + while {1} { + set now [clock seconds] + if {$now!=$start && !($now & 1)} { + break + } + after 50 } - after 50 } } set file [makeFile "data" touch.me] @@ -1161,7 +1162,7 @@ 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 {[string equal $tcl_platform(platform) "unix"]} { + if {[testConstraint unix]} { set name /tmp/tcl.test.[pid] } else { set name [file join [temporaryDirectory] tf] @@ -1543,3 +1544,7 @@ cd $cmdAHwd ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/cmdInfo.test b/tests/cmdInfo.test index b4022af..799c6e3 100644 --- a/tests/cmdInfo.test +++ b/tests/cmdInfo.test @@ -13,17 +13,15 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdInfo.test,v 1.8 2003/11/14 20:44:46 dgp Exp $ +# RCS: @(#) $Id: cmdInfo.test,v 1.9 2006/03/21 11:12:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } -::tcltest::testConstraint testcmdinfo \ - [llength [info commands testcmdinfo]] -::tcltest::testConstraint testcmdtoken \ - [llength [info commands testcmdtoken]] +testConstraint testcmdinfo [llength [info commands testcmdinfo]] +testConstraint testcmdtoken [llength [info commands testcmdtoken]] test cmdinfo-1.1 {command procedure and clientData} {testcmdinfo} { testcmdinfo create x1 @@ -104,3 +102,7 @@ catch {namespace delete cmdInfoNs1::cmdInfoNs2 cmdInfoNs1} catch {rename x1 ""} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index b1e36bd..cd406a1 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -12,14 +12,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: compExpr-old.test,v 1.16 2005/11/08 22:09:56 dgp Exp $ +# RCS: @(#) $Id: compExpr-old.test,v 1.17 2006/03/21 11:12:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } -if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { +if {[catch {expr T1()} msg] && $msg eq {unknown math function "T1"}} { testConstraint testmathfunctions 0 } else { testConstraint testmathfunctions 1 @@ -81,7 +81,10 @@ proc testIEEE {} { } } } -::tcltest::testConstraint ieeeFloatingPoint [testIEEE] +testConstraint ieeeFloatingPoint [testIEEE] + +testConstraint longIs32bit [expr {int(0x80000000) < 0}] +testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] # procedures used below @@ -358,13 +361,9 @@ test compExpr-old-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8 # The following test is different for 32-bit versus 64-bit # architectures because LONG_MIN is different -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] - test compExpr-old-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit { expr {int(1<<63)} } -9223372036854775808 - test compExpr-old-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit { expr {int(1<<31)} } -2147483648 diff --git a/tests/compExpr.test b/tests/compExpr.test index 42e5cd5..b9e8ba9 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -8,14 +8,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: compExpr.test,v 1.9 2005/05/10 18:35:17 kennykb Exp $ +# RCS: @(#) $Id: compExpr.test,v 1.10 2006/03/21 11:12:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { +if {[catch {expr T1()} msg] && $msg eq {unknown math function "T1"}} { testConstraint testmathfunctions 0 } else { testConstraint testmathfunctions 1 diff --git a/tests/env.test b/tests/env.test index a1e50d9..4005afb 100644 --- a/tests/env.test +++ b/tests/env.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: env.test,v 1.23 2005/11/03 00:17:31 patthoyts Exp $ +# RCS: @(#) $Id: env.test,v 1.24 2006/03/21 11:12:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -70,7 +70,7 @@ set printenvScript [makeFile { } set names [lsort [array names env]] - if {$tcl_platform(platform) == "windows"} { + if {[testConstraint win]} { lrem names HOME lrem names COMSPEC lrem names ComSpec diff --git a/tests/execute.test b/tests/execute.test index bab3ced..1b3d75f 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -14,7 +14,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: execute.test,v 1.21 2005/11/09 20:24:10 dgp Exp $ +# RCS: @(#) $Id: execute.test,v 1.22 2006/03/21 11:12:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -27,14 +27,13 @@ catch {unset x} catch {unset y} catch {unset msg} -::tcltest::testConstraint testobj \ - [expr {[info commands testobj] != {} \ - && [info commands testdoubleobj] != {} \ - && [info commands teststringobj] != {} \ - && [info commands testobj] != {}}] +testConstraint testobj [expr { + [llength [info commands testobj]] + && [llength [info commands testdoubleobj]] + && [llength [info commands teststringobj]] +}] -::tcltest::testConstraint longIs32bit \ - [expr {int(0x80000000) < 0}] +testConstraint longIs32bit [expr {int(0x80000000) < 0}] # Tests for the omnibus TclExecuteByteCode function: @@ -775,3 +774,7 @@ catch {unset y} catch {unset msg} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/expr-old.test b/tests/expr-old.test index e6edcde..0e42a76 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -13,14 +13,19 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: expr-old.test,v 1.31 2005/11/09 20:24:10 dgp Exp $ +# RCS: @(#) $Id: expr-old.test,v 1.32 2006/03/21 11:12:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 namespace import -force ::tcltest::* } -if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} { +testConstraint testexprlong [llength [info commands testexprlong]] +testConstraint testexprdouble [llength [info commands testexprdouble]] +testConstraint testexprstring [llength [info commands testexprstring]] +testConstraint longIs32bit [expr {int(0x80000000) < 0}] + +if {[catch {expr T1()} msg] && $msg eq {unknown math function "T1"}} { testConstraint testmathfunctions 0 } else { testConstraint testmathfunctions 1 @@ -82,7 +87,7 @@ proc testIEEE {} { } } } -::tcltest::testConstraint ieeeFloatingPoint [testIEEE] +testConstraint ieeeFloatingPoint [testIEEE] # First, test all of the integer operators individually. @@ -1017,11 +1022,6 @@ test expr-old-36.16 {ExprLooksLikeInt procedure} { expr {$x+1} } [expr 0x100000000000000000000000000000000000000] -testConstraint testexprlong [llength [info commands testexprlong]] -testConstraint testexprdouble [llength [info commands testexprdouble]] -testConstraint testexprstring [llength [info commands testexprstring]] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] - test expr-old-37.1 {Check that Tcl_ExprLong doesn't modify interpreter result if no error} testexprlong { testexprlong 4+1 } {This is a result: 5} diff --git a/tests/fCmd.test b/tests/fCmd.test index 6d2abc0..00e442a 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.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: fCmd.test,v 1.52 2006/03/20 11:39:03 dkf Exp $ +# RCS: @(#) $Id: fCmd.test,v 1.53 2006/03/21 11:12:29 dkf Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -25,9 +25,26 @@ testConstraint notNetworkFilesystem 0 testConstraint 95or98 [expr {[testConstraint 95] || [testConstraint 98]}] testConstraint 2000orNewer [expr {![testConstraint 95or98]}] +# Find a group that exists on this Unix system, or else skip tests that +# require Unix groups. +testConstraint foundGroup [expr {![textConstraint unix]}] +if {[testConstraint unix]} { + catch { + set groupList [exec groups] + set group [lindex $groupList 0] + testConstraint foundGroup 1 + } +} + +testConstraint fileSharing 0 +testConstraint notFileSharing 1 +testConstraint xdev 0 +testConstraint linkFile 1 +testConstraint linkDirectory 1 + # Several tests require need to match results against the unix username set user {} -if {$tcl_platform(platform) == "unix"} { +if {[testConstraint unix]} { catch {set user [exec whoami]} if {$user == ""} { catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} @@ -44,7 +61,7 @@ proc createfile {file {string a}} { return $string } -# +# # checkcontent -- # # Ensures that file "file" contains only the string "matchString" @@ -54,7 +71,7 @@ proc checkcontent {file matchString} { if {[catch { set f [open $file] set fileString [read $f] - close $f + close $f }]} { return 0 } @@ -99,12 +116,8 @@ proc contents {file} { } cd [temporaryDirectory] -testConstraint fileSharing 0 -testConstraint notFileSharing 1 -testConstraint xdev 0 - -if {$tcl_platform(platform) == "unix"} { +if {[testConstraint unix]} { if {[catch {set m1 [exec df .]; set m2 [exec df /tmp]}] == 0} { set m1 [string range $m1 0 [expr [string first " " $m1]-1]] set m2 [string range $m2 0 [expr [string first " " $m2]-1]] @@ -221,10 +234,10 @@ test fCmd-3.15 {FileCopyRename: source[0] == '\0'} {notRoot unixOrPc} { } {1 {error renaming "/" to "td1": file already exists}} test fCmd-3.16 {FileCopyRename: break on first error} {notRoot} { cleanup - createfile tf1 - createfile tf2 - createfile tf3 - createfile tf4 + createfile tf1 + createfile tf2 + createfile tf3 + createfile tf4 file mkdir td1 createfile [file join td1 tf3] list [catch {file rename tf1 tf2 tf3 tf4 td1} msg] $msg @@ -359,7 +372,7 @@ test fCmd-5.8 {TclFileDeleteCmd: file doesn't exist: lstat(name) != 0} {notRoot} set x [file exists tf1] file delete tf1 list $x [file exists tf1] -} {0 0} +} {0 0} test fCmd-5.9 {TclFileDeleteCmd: is directory} {notRoot} { cleanup file mkdir td1 @@ -533,7 +546,7 @@ test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} \ file attributes td1 -permissions 0000 set msg [list [catch {file rename td1 /tmp} msg] $msg] file attributes td1 -permissions 0755 - set msg + set msg } {1 {error renaming "td1": permission denied}} test fCmd-6.24 {CopyRenameOneFile: error uses original name} \ {unix notRoot} { @@ -687,7 +700,7 @@ test fCmd-9.3 {file rename: comprehensive: file to new name} {notRoot testchmod} file rename tf1 tf3 file rename tf2 tf4 list [lsort [glob tf*]] [file writable tf3] [file writable tf4] -} {{tf3 tf4} 1 0} +} {{tf3 tf4} 1 0} test fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc notRoot testchmod} { cleanup file mkdir td1 td2 @@ -695,7 +708,7 @@ test fCmd-9.4 {file rename: comprehensive: dir to new name} {unixOrPc notRoot te file rename td1 td3 file rename td2 td4 list [lsort [glob td*]] [file writable td3] [file writable td4] -} {{td3 td4} 1 0} +} {{td3 td4} 1 0} test fCmd-9.5 {file rename: comprehensive: file to self} {notRoot testchmod} { cleanup createfile tf1 tf1 @@ -704,7 +717,7 @@ test fCmd-9.5 {file rename: comprehensive: file to self} {notRoot testchmod} { file rename -force tf1 tf1 file rename -force tf2 tf2 list [contents tf1] [contents tf2] [file writable tf1] [file writable tf2] -} {tf1 tf2 1 0} +} {tf1 tf2 1 0} test fCmd-9.6 {file rename: comprehensive: dir to self} {notRoot unixOrPc testchmod} { cleanup file mkdir td1 @@ -713,7 +726,7 @@ test fCmd-9.6 {file rename: comprehensive: dir to self} {notRoot unixOrPc testch file rename -force td1 . file rename -force td2 . list [lsort [glob td*]] [file writable td1] [file writable td2] -} {{td1 td2} 1 0} +} {{td1 td2} 1 0} test fCmd-9.7 {file rename: comprehensive: file to existing file} {notRoot testchmod} { cleanup createfile tf1 @@ -735,7 +748,7 @@ test fCmd-9.7 {file rename: comprehensive: file to existing file} {notRoot testc file rename -force tfs2 tfd2 file rename -force tfs3 tfd3 file rename -force tfs4 tfd4 - list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] + list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] } {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0} test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup { cleanup @@ -753,7 +766,7 @@ test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup { file mkdir [file join tdd2 tds2] file mkdir [file join tdd3 tds3] file mkdir [file join tdd4 tds4] - if {$tcl_platform(platform) != "unix"} { + if {![testConstraint unix]} { testchmod 555 tds3 testchmod 555 tds4 } @@ -764,12 +777,12 @@ test fCmd-9.8 {file rename: comprehensive: dir to empty dir} -setup { file rename -force tds2 tdd2 file rename -force tds3 tdd3 file rename -force tds4 tdd4 - if {$tcl_platform(platform) != "unix"} { - set w3 [file writable [file join tdd3 tds3]] - set w4 [file writable [file join tdd4 tds4]] - } else { + if {[testConstraint unix]} { set w3 0 set w4 0 + } else { + set w3 [file writable [file join tdd3 tds3]] + set w4 [file writable [file join tdd4 tds4]] } list [lsort [glob td*]] $msg [file writable [file join tdd1 tds1]] \ [file writable [file join tdd2 tds2]] $w3 $w4 @@ -782,15 +795,15 @@ test fCmd-9.9 {file rename: comprehensive: dir to non-empty dir} -setup { file mkdir tds2 file mkdir [file join tdd1 tds1 xxx] file mkdir [file join tdd2 tds2 xxx] - if {$tcl_platform(platform) != "unix"} { + if {![testConstraint unix]} { testchmod 555 tds2 } set a1 [list [catch {file rename -force tds1 tdd1} msg] $msg] set a2 [list [catch {file rename -force tds2 tdd2} msg] $msg] - if {$tcl_platform(platform) != "unix"} { - set w2 [file writable tds2] - } else { + if {[testConstraint unix]} { set w2 0 + } else { + set w2 [file writable tds2] } list [lsort [glob td*]] $a1 $a2 [file writable tds1] $w2 } -match glob -result \ @@ -811,15 +824,15 @@ test fCmd-9.11 {file rename: comprehensive: dir to new name and dir} {notRoot te file mkdir td1 file mkdir td2 file mkdir td3 - if {$tcl_platform(platform) != "unix"} { + if {![testConstraint unix]} { testchmod 555 td2 } file rename td1 [file join td3 td3] file rename td2 [file join td3 td4] - if {$tcl_platform(platform) != "unix"} { - set w4 [file writable [file join td3 td4]] - } else { + if {[testConstraint unix]} { set w4 0 + } else { + set w4 [file writable [file join td3 td4]] } list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \ [file writable [file join td3 td3]] $w4 @@ -950,7 +963,7 @@ test fCmd-10.4 {file copy: comprehensive: file to existing file} {notRoot testch file copy -force tfs2 tfd2 file copy -force tfs3 tfd3 file copy -force tfs4 tfd4 - list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] + list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4] } {{tf1 tf2 tfd1 tfd2 tfd3 tfd4 tfs1 tfs2 tfs3 tfs4} {1 {error copying "tf1" to "tf2": file already exists}} 1 1 0 0} test fCmd-10.5 {file copy: comprehensive: dir to empty dir} {notRoot testchmod} { cleanup @@ -973,7 +986,7 @@ test fCmd-10.5 {file copy: comprehensive: dir to empty dir} {notRoot testchmod} set a3 [catch {file copy -force tds2 tdd2}] set a4 [catch {file copy -force tds3 tdd3}] set a5 [catch {file copy -force tds4 tdd4}] - list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5 + list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5 } [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}] test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} \ {notRoot unixOrPc testchmod} { @@ -1047,9 +1060,9 @@ test fCmd-10.12 {file rename: rename to empty file name} { createfile tf1 list [catch {file rename tf1 ""} msg] $msg } {1 {error renaming "tf1" to "": no such file or directory}} -cleanup +cleanup -# old tests +# old tests test fCmd-11.1 {TclFileRenameCmd: -- option } {notRoot} { catch {file delete -force -- -tfa1} @@ -1080,9 +1093,9 @@ test fCmd-11.4 {TclFileRenameCmd: target filename translation failing} {notRoot} } {1} test fCmd-11.5 {TclFileRenameCmd: > 1 source & target is not a dir} {notRoot} { catch {file delete -force -- tfa1 tfa2 tfa3} - createfile tfa1 - createfile tfa2 - createfile tfa3 + createfile tfa1 + createfile tfa2 + createfile tfa3 set result [catch {file rename tfa1 tfa2 tfa3}] file delete tfa1 tfa2 tfa3 set result @@ -1104,7 +1117,7 @@ test fCmd-11.7 {TclFileRenameCmd: : multiple files into directory} {notRoot} { file rename tfa1 tfa2 tfad set r1 [checkcontent tfad/tfa1 $s1] set r2 [checkcontent tfad/tfa2 $s2] - + set result [expr $r1 && $r2 && ![file exists tfa1] && ![file exists tfa2]] file delete -force tfad @@ -1188,7 +1201,7 @@ test fCmd-12.7 {renamefile: renaming directory into offspring} {notRoot} { file mkdir tfad file mkdir tfad/dir set result [catch {file rename tfad tfad/dir}] - file delete -force tfad + file delete -force tfad set result } {1} test fCmd-12.8 {renamefile: generic error} {unix notRoot} { @@ -1260,9 +1273,9 @@ test fCmd-13.5 {TclCopyFilesCmd: target filename translation failing} { } {1} test fCmd-13.6 {TclCopyFilesCmd: > 1 source & target is not a dir} {notRoot} { catch {file delete -force -- tfa1 tfa2 tfa3} - createfile tfa1 - createfile tfa2 - createfile tfa3 + createfile tfa1 + createfile tfa2 + createfile tfa3 set result [catch {file copy tfa1 tfa2 tfa3}] file delete tfa1 tfa2 tfa3 set result @@ -1306,7 +1319,7 @@ test fCmd-13.9 {TclCopyFilesCmd: error copying file to directory} {notRoot} { # # Coverage tests for copyfile() -# +# test fCmd-14.1 {copyfile: source filename translation failing} {notRoot} { global env set temp $env(HOME) @@ -1392,7 +1405,7 @@ test fCmd-14.8 {copyfile: copy directory failing} {unix notRoot} { test fCmd-15.1 {TclMakeDirsCmd: target filename translation failing} {notRoot} { global env set temp $env(HOME) - unset env(HOME) + unset env(HOME) set result [catch {file mkdir ~/tfa}] set env(HOME) $temp set result @@ -1515,7 +1528,7 @@ test fCmd-16.9 {error while deleting file } {unix notRoot} { file attributes tfa -permissions 0555 set result [catch {file delete tfa/a }] ####### - ####### If any directory in a tree that is being removed does not + ####### If any directory in a tree that is being removed does not ####### have write permission, the process will fail! ####### This is also the case with "rm -rf" ####### @@ -1710,7 +1723,7 @@ test fCmd-18.14 {TclFileRenameCmd : rename a path with sym link} \ file mkdir tfa1/a/b/c/d file mkdir tfa2 - set f [file join [pwd] tfa1/a/b] + set f [file join [pwd] tfa1/a/b] set f2 [file join [pwd] {tfa2/b alias}] file link -symbolic $f2 $f file rename {tfa2/b alias/c} tfa3 @@ -1738,7 +1751,7 @@ test fCmd-18.16 {TclFileRenameCmd: rename a dangling symlink} {unix notRoot} { file mkdir tfa1 file link -symbolic tfalink tfa1 - file delete tfa1 + file delete tfa1 file rename tfalink tfa2 set result [expr [string compare [file type tfa2] "link"] == 0] file delete tfa2 @@ -1773,7 +1786,7 @@ test fCmd-19.3 {recursive remove} {notRoot} { } {0} # -# TclUnixDeleteFile and TraversalDelete are covered by tests from the +# TclUnixDeleteFile and TraversalDelete are covered by tests from the # TclDeleteFilesCmd suite # # @@ -1806,7 +1819,7 @@ test fCmd-20.2 {TraverseUnixTree : recursive delete of large directory: Bug 1034 # # Feature testing for TclCopyFilesCmd -# +# test fCmd-21.1 {copy : single file to nonexistant } {notRoot} { catch {file delete -force -- tfa1 tfa2} set s [createfile tfa1] @@ -1835,9 +1848,9 @@ test fCmd-21.3 {copy : single file into directory } {notRoot} { test fCmd-21.4 {copy : more than one source and target is not a directory} \ {notRoot} { catch {file delete -force -- tfa1 tfa2 tfa3} - createfile tfa1 - createfile tfa2 - createfile tfa3 + createfile tfa1 + createfile tfa2 + createfile tfa3 set result [catch {file copy tfa1 tfa2 tfa3}] file delete tfa1 tfa2 tfa3 set result @@ -1874,7 +1887,7 @@ test fCmd-21.7.1 {TclCopyFilesCmd: copy a dangling link} {unix notRoot dontCopyL file link -symbolic tfalink tfad1 file delete tfad1 set result [list [catch {file copy tfalink tfalink2} msg] $msg] - file delete -force tfalink tfalink2 + file delete -force tfalink tfalink2 set result } {1 {error copying "tfalink": the target of this link doesn't exist}} test fCmd-21.7.2 {TclCopyFilesCmd: copy a dangling link} {unix notRoot} { @@ -1883,7 +1896,7 @@ test fCmd-21.7.2 {TclCopyFilesCmd: copy a dangling link} {unix notRoot} { file delete tfad1 file copy tfalink tfalink2 set result [string match [file type tfalink2] link] - file delete tfalink tfalink2 + file delete tfalink tfalink2 set result } {1} test fCmd-21.8.1 {TclCopyFilesCmd: copy a link } {unix notRoot dontCopyLinks} { @@ -1959,10 +1972,10 @@ test fCmd-22.1 {TclpRenameFile: rename and overwrite in a single dir} {notRoot} } {1} test fCmd-22.2 {TclpRenameFile: attempt to overwrite itself} {unix notRoot} { catch {file delete -force -- tfa1} - set s [createfile tfa1] + set s [createfile tfa1] file rename -force tfa1 tfa1 set result [checkcontent tfa1 $s] - file delete tfa1 + file delete tfa1 set result } {1} test fCmd-22.3 {TclpRenameFile: rename dir to existing dir} {notRoot} { @@ -2012,12 +2025,12 @@ test fCmd-23.1 {TclMacRmdir: trying to remove a nonempty directory} {notRoot} { file mkdir [file join tfad dir] set result [catch {file delete tfad}] - file delete -force tfad + file delete -force tfad set result } {1} # -# TclMacDeleteFile +# TclMacDeleteFile # Error cases are not covered. # test fCmd-24.1 {TclMacDeleteFile: deleting a normal file} {notRoot} { @@ -2089,7 +2102,7 @@ test fCmd-26.2 {TclDeleteFilesCmd: delete dir with symlink} {unix notRoot} { set r1 [file isdir tfad1] set r2 [file exists tfad2] - + set result [expr $r1 && !$r2] file delete tfad1 set result @@ -2104,7 +2117,7 @@ test fCmd-26.3 {TclDeleteFilesCmd: delete dangling symlink} {unix notRoot} { set r1 [file exists tfad1] set r2 [file exists tfad2] - + set result [expr !$r1 && !$r2] set result } {1} @@ -2125,18 +2138,6 @@ test fCmd-27.4 {TclFileAttrsCmd - getting one option} { set attrs [file attributes foo.tmp] list [catch {file attributes foo.tmp {expand}[lindex $attrs 0]}] [file delete -force -- foo.tmp] } {0 {}} -# Find a group that exists on this Unix system, or else skip tests that -# require Unix groups. -if {$tcl_platform(platform) == "unix"} { - ::tcltest::testConstraint foundGroup 0 - catch { - set groupList [exec groups] - set group [lindex $groupList 0] - ::tcltest::testConstraint foundGroup 1 - } -} else { - ::tcltest::testConstraint foundGroup 1 -} test fCmd-27.5 {TclFileAttrsCmd - setting one option} {foundGroup} { catch {file delete -force -- foo.tmp} createfile foo.tmp @@ -2150,18 +2151,13 @@ test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} {foundGroup} { list [catch {file attributes foo.tmp {expand}[lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp] } {0 {} {}} -if {[string equal $tcl_platform(platform) "windows"]} { - if {[string index $tcl_platform(osVersion) 0] >= 5 \ - && ([lindex [file system [temporaryDirectory]] 1] == "NTFS")} { - tcltest::testConstraint linkDirectory 1 - tcltest::testConstraint linkFile 1 - } else { - tcltest::testConstraint linkDirectory 0 - tcltest::testConstraint linkFile 0 - } -} else { - tcltest::testConstraint linkFile 1 - tcltest::testConstraint linkDirectory 1 +if { + [testConstraint win] && + ([string index $tcl_platform(osVersion) 0] < 5 + || [lindex [file system [temporaryDirectory]] 1] ne "NTFS") +} then { + testConstraint linkDirectory 0 + testConstraint linkFile 0 } test fCmd-28.1 {file link} { diff --git a/tests/fileName.test b/tests/fileName.test index 5e4286e..4cd079b 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -10,15 +10,24 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: fileName.test,v 1.50 2006/03/19 23:04:24 vincentdarley Exp $ +# RCS: @(#) $Id: fileName.test,v 1.51 2006/03/21 11:12:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]] -testConstraint testtranslatefilename [string equal testtranslatefilename [info commands testtranslatefilename]] +testConstraint testsetplatform [llength [info commands testsetplatform]] +testConstraint testtranslatefilename [llength [info commands testtranslatefilename]] +testConstraint linkDirectory 1 +testConstraint symbolicLinkFile 1 +if {[testConstraint win]} { + if {[string index $tcl_platform(osVersion) 0] < 5 \ + || [lindex [file system [temporaryDirectory]] 1] ne "NTFS"} { + testConstraint linkDirectory 0 + } + testConstraint symbolicLinkFile 0 +} global env if {[testConstraint testsetplatform]} { @@ -778,21 +787,6 @@ test filename-11.17.1 {Tcl_GlobCmd} {win} { [file join $globname x,z1.c]\ [file join $globname x1.c]\ [file join $globname y1.c] [file join $globname z1.c]]]] -if {[string equal $tcl_platform(platform) "windows"]} { - if {[string index $tcl_platform(osVersion) 0] >= 5 \ - && ([lindex [file system [temporaryDirectory]] 1] == "NTFS")} { - testConstraint linkDirectory 1 - } else { - testConstraint linkDirectory 0 - } -} else { - testConstraint linkDirectory 1 -} -if {[string equal $tcl_platform(platform) "windows"]} { - testConstraint symbolicLinkFile 0 -} else { - testConstraint symbolicLinkFile 1 -} test filename-11.17.2 {Tcl_GlobCmd} {notRoot linkDirectory} { set dir [pwd] set ret "error in test" diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 7487743..06ab643 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -11,15 +11,8 @@ package require tcltest 2 namespace eval ::tcl::test::fileSystem { + namespace import ::tcltest::* - namespace import ::tcltest::cleanupTests - namespace import ::tcltest::makeDirectory - namespace import ::tcltest::makeFile - namespace import ::tcltest::removeDirectory - namespace import ::tcltest::removeFile - namespace import ::tcltest::test - namespace import ::tcltest::testConstraint - catch { file delete -force link.file file delete -force dir.link @@ -39,7 +32,7 @@ makeFile "test file in directory" [file join dir.dir inside.file] testConstraint unusedDrive 0 set drive {} -if {$::tcl_platform(platform) eq "windows"} { +if {[testConstraint win]} { set vols [string map [list :/ {}] [file volumes]] for {set i 0} {$i < 26} {incr i} { set drive [format %c [expr {$i + 65}]] @@ -54,7 +47,7 @@ if {$::tcl_platform(platform) eq "windows"} { testConstraint moreThanOneDrive 0 set drives [list] -if {$::tcl_platform(platform) eq "windows"} { +if {[testConstraint win]} { set dir [pwd] foreach vol [file volumes] { if {![catch {cd $vol}]} { @@ -281,7 +274,7 @@ test filesystem-1.32 {link normalisation: link near filesystem root} {testsetpla test filesystem-1.33 {link normalisation: link near filesystem root} {testsetplatform} { testsetplatform windows set res [file normalize C:/../bar] - if {$::tcl_platform(platform) == "unix"} { + if {[testConstraint unix]} { # Some unices go further in normalizing this -- not really # a problem since this is a Windows test regexp {C:/bar$} $res res @@ -902,7 +895,6 @@ test filesystem-8.3 {path objects and empty string} { set anchor "" set dst foo set res $dst - set yyy [file split $anchor] set dst [file join $anchor $dst] lappend res $dst $yyy diff --git a/tests/format.test b/tests/format.test index f99861d..321f52f 100644 --- a/tests/format.test +++ b/tests/format.test @@ -10,24 +10,26 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: format.test,v 1.23 2005/10/13 21:49:46 dkf Exp $ +# RCS: @(#) $Id: format.test,v 1.24 2006/03/21 11:12:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } +# %u output depends on word length, so this test is not portable. +testConstraint longIs32bit [expr {int(0x80000000) < 0}] +testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] +testConstraint wideIs64bit \ + [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] +testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] + test format-1.1 {integer formatting} { format "%*d %d %d %d" 6 34 16923 -12 -1 } { 34 16923 -12 -1} test format-1.2 {integer formatting} { format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12 } { 6 34 16923 -12 -1 0xe 0XC} - -# %u output depends on word length, so this test is not portable. -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] - test format-1.3 {integer formatting} longIs32bit { format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0 } { 6 34 16923 4294967284 -1 0} @@ -43,10 +45,8 @@ test format-1.5 {integer formatting} { test format-1.6 {integer formatting} { format "%00*d" 6 34 } {000034} - # Printing negative numbers in hex or octal format depends on word # length, so these tests are not portable. - test format-1.7 {integer formatting} longIs32bit { format "%4x %4x %4x %4x" 6 34 16923 -12 -1 } { 6 22 421b fffffff4} @@ -426,6 +426,7 @@ test format-11.12 {XPG3 %$n specifiers} { test format-12.1 {negative width specifiers} { format "%*d" -47 25 } {25 } + test format-13.1 {tcl_precision fuzzy comparison} { catch {unset a} catch {unset b} @@ -475,6 +476,7 @@ test format-13.5 {tcl_precision fuzzy comparison} { set c [expr $a + $b] format {%0.10f %0.12f %0.15f} $c $c $c } {1.4444444444 1.444444444444 1.444444444443990} + test format-14.1 {testing MAX_FLOAT_SIZE for 0 and 1} { format {%s} "" } {} @@ -502,16 +504,11 @@ for {set i 0} {$i < 290} {incr i} { } for {set i 290} {$i < 400} {incr i} { test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} { - format {%s} $b + format {%s} $b } $b append b "x" } -::tcltest::testConstraint wideIs64bit \ - [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] -::tcltest::testConstraint wideBiggerThanInt \ - [expr {wide(0x80000000) != int(0x80000000)}] - test format-17.1 {testing %d with wide} {wideIs64bit wideBiggerThanInt} { format %d 7810179016327718216 } 1819043144 @@ -563,3 +560,7 @@ catch {unset c} catch {unset d} ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/io.test b/tests/io.test index f1299af..a25f3c3 100644 --- a/tests/io.test +++ b/tests/io.test @@ -13,21 +13,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: io.test,v 1.70 2006/03/16 19:12:17 andreas_kupries Exp $ +# RCS: @(#) $Id: io.test,v 1.71 2006/03/21 11:12:29 dkf Exp $ if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." return } namespace eval ::tcl::test::io { - - namespace import ::tcltest::cleanupTests - namespace import ::tcltest::interpreter - namespace import ::tcltest::makeFile - namespace import ::tcltest::removeFile - namespace import ::tcltest::test - namespace import ::tcltest::testConstraint - namespace import ::tcltest::viewFile + namespace import ::tcltest::* testConstraint testchannel [llength [info commands testchannel]] testConstraint exec [llength [info commands exec]] @@ -37,6 +30,7 @@ testConstraint fcopy [llength [info commands fcopy]] testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] testConstraint testmainthread [llength [info commands testmainthread]] +testConstraint testthread [llength [info commands testthread]] # You need a *very* special environment to do some tests. In # particular, many file systems do not support large-files... @@ -47,6 +41,8 @@ testConstraint largefileSupport 0 set umaskValue 0 testConstraint umask [expr {![catch {set umaskValue [exec /bin/sh -c umask]}]}] +testConstraint makeFileInHome [expr {![file exists ~/_test_] && [file writable ~]}] + # set up a long data file for some of the following tests set path(longfile) [makeFile {} longfile] @@ -5279,7 +5275,6 @@ test io-40.15 {POSIX open access modes: RDWR} { close $f lappend x [viewFile test3] } {zzy abzzy} -testConstraint makeFileInHome [expr {![file exists ~/_test_] && [file writable ~]}] test io-40.16 {tilde substitution in open} -constraints makeFileInHome -setup { makeFile {Some text} _test_ ~ } -body { @@ -7160,8 +7155,6 @@ test io-70.0 {Cutting & Splicing channels} {testchannel} { # nop after the first call, and placement of its defintion in a # central location. -testConstraint testthread [expr {[info commands testthread] != {}}] - if {[testConstraint testthread]} { testthread errorproc ThreadError diff --git a/tests/ioUtil.test b/tests/ioUtil.test index 1671572..bb084b0 100644 --- a/tests/ioUtil.test +++ b/tests/ioUtil.test @@ -1,26 +1,24 @@ # This file (ioUtil.test) tests the hookable TclStat(), TclAccess(), # and Tcl_OpenFileChannel, routines in the file generic/tclIOUtils.c. # 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. -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# RCS: @(#) $Id: ioUtil.test,v 1.15 2003/11/14 20:44:46 dgp Exp $ - +# errors. No output means no errors were found. +# +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: ioUtil.test,v 1.16 2006/03/21 11:12:29 dkf Exp $ + if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } -::tcltest::testConstraint testopenfilechannelproc \ +testConstraint testopenfilechannelproc \ [llength [info commands testopenfilechannelproc]] -::tcltest::testConstraint testaccessproc \ - [llength [info commands testaccessproc]] -::tcltest::testConstraint teststatproc \ - [llength [info commands teststatproc]] +testConstraint testaccessproc [llength [info commands testaccessproc]] +testConstraint teststatproc [llength [info commands teststatproc]] set unsetScript { catch {unset testStat1(size)} @@ -308,3 +306,7 @@ cd $oldpwd # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/iogt.test b/tests/iogt.test index 9e09270..ac52f5b 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -10,21 +10,16 @@ # Copyright (c) 2000 Andreas Kupries. # All rights reserved. # -# RCS: @(#) $Id: iogt.test,v 1.13 2005/05/10 18:35:22 kennykb Exp $ +# RCS: @(#) $Id: iogt.test,v 1.14 2006/03/21 11:12:29 dkf Exp $ if {[catch {package require tcltest 2.1}]} { puts stderr "Skipping tests in [info script]. tcltest 2.1 required." return } namespace eval ::tcl::test::iogt { + namespace import ::tcltest::* - namespace import ::tcltest::cleanupTests - namespace import ::tcltest::makeFile - namespace import ::tcltest::removeFile - namespace import ::tcltest::test - namespace import ::tcltest::testConstraint - - testConstraint testchannel [llength [info commands testchannel]] +testConstraint testchannel [llength [info commands testchannel]] set path(dummy) [makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-= } dummy] @@ -882,10 +877,6 @@ delete/read {} *ignored* flush/write {} {} delete/write {} *ignored*} - - - - proc constX {op data} { # replace anything coming in with a same-length string of x'es. switch -- $op { diff --git a/tests/link.test b/tests/link.test index 84fa154..08251b1 100644 --- a/tests/link.test +++ b/tests/link.test @@ -11,15 +11,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: link.test,v 1.14 2005/09/08 14:14:21 dkf Exp $ +# RCS: @(#) $Id: link.test,v 1.15 2006/03/21 11:12:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } -::tcltest::testConstraint testlink \ - [expr {[info commands testlink] != {}}] +testConstraint testlink [llength [info commands testlink]] foreach i {int real bool string} { catch {unset $i} diff --git a/tests/load.test b/tests/load.test index d1bdc04..6ef2f53 100644 --- a/tests/load.test +++ b/tests/load.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: load.test,v 1.14 2005/07/28 18:42:32 dgp Exp $ +# RCS: @(#) $Id: load.test,v 1.15 2006/03/21 11:12:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -25,20 +25,18 @@ set ext [info sharedlibextension] set testDir [file join [file dirname [info nameofexecutable]] dltest] set x [file join $testDir pkga$ext] set dll "[file tail $x]Required" -::tcltest::testConstraint $dll [file readable $x] +testConstraint $dll [file readable $x] # Tests also require that this DLL has not already been loaded. set loaded "[file tail $x]Loaded" set alreadyLoaded [info loaded] -::tcltest::testConstraint $loaded \ - [expr {![string match *pkga* $alreadyLoaded]}] +testConstraint $loaded [expr {![string match *pkga* $alreadyLoaded]}] set alreadyTotalLoaded [info loaded] # Certain tests require the 'teststaticpkg' command from tcltest -::tcltest::testConstraint teststaticpkg \ - [string compare {} [info commands teststaticpkg]] +testConstraint teststaticpkg [llength [info commands teststaticpkg]] test load-1.1 {basic errors} {} { diff --git a/tests/macOSXFCmd.test b/tests/macOSXFCmd.test index b5f77c5..15b3909 100644 --- a/tests/macOSXFCmd.test +++ b/tests/macOSXFCmd.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: macOSXFCmd.test,v 1.3 2006/03/21 11:06:23 das Exp $ +# RCS: @(#) $Id: macOSXFCmd.test,v 1.4 2006/03/21 11:12:29 dkf Exp $ # if {[lsearch [namespace children] ::tcltest] == -1} { @@ -24,8 +24,7 @@ cd [temporaryDirectory] # check whether macosx file attributes are supported testConstraint macosxFileAttr 0 -if {$tcl_platform(platform) eq "unix" && \ - $tcl_platform(os) eq "Darwin"} { +if {[testConstraint unix] && $tcl_platform(os) eq "Darwin"} { catch {file delete -force -- foo.test} close [open foo.test w] catch { diff --git a/tests/main.test b/tests/main.test index 3a14789..5eab892 100644 --- a/tests/main.test +++ b/tests/main.test @@ -1,6 +1,6 @@ # This file contains a collection of tests for generic/tclMain.c. # -# RCS: @(#) $Id: main.test,v 1.17 2006/02/09 15:22:52 dgp Exp $ +# RCS: @(#) $Id: main.test,v 1.18 2006/03/21 11:12:29 dkf Exp $ if {[catch {package require tcltest 2.0.2}]} { puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." @@ -8,15 +8,7 @@ if {[catch {package require tcltest 2.0.2}]} { } namespace eval ::tcl::test::main { - - namespace import ::tcltest::test - namespace import ::tcltest::testConstraint - namespace import ::tcltest::interpreter - namespace import ::tcltest::cleanupTests - namespace import ::tcltest::makeFile - namespace import ::tcltest::removeFile - namespace import ::tcltest::temporaryDirectory - namespace import ::tcltest::workingDirectory + namespace import ::tcltest::* # Is [exec] defined? testConstraint exec [llength [info commands exec]] @@ -615,8 +607,7 @@ namespace eval ::tcl::test::main { after cancel $id set wait } -cleanup { - if {[string equal timeout $wait] - && [string equal unix $::tcl_platform(platform)]} { + if {[string equal timeout $wait] && [testConstraint unix]} { exec kill [pid $f] } close $f @@ -639,8 +630,7 @@ namespace eval ::tcl::test::main { after cancel $id set wait } -cleanup { - if {[string equal timeout $wait] - && [string equal unix $::tcl_platform(platform)]} { + if {[string equal timeout $wait] && [testConstraint unix]} { exec kill [pid $f] } close $f diff --git a/tests/parse.test b/tests/parse.test index 9657951..8989033 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: parse.test,v 1.23 2006/03/06 21:56:34 dgp Exp $ +# RCS: @(#) $Id: parse.test,v 1.24 2006/03/21 11:12:29 dkf Exp $ if {[catch {package require tcltest 2.0.2}]} { puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." @@ -16,18 +16,15 @@ if {[catch {package require tcltest 2.0.2}]} { } namespace eval ::tcl::test::parse { - namespace import ::tcltest::test - namespace import ::tcltest::testConstraint - namespace import ::tcltest::cleanupTests - namespace import ::tcltest::bytestring + namespace import ::tcltest::* - testConstraint testparser [llength [info commands testparser]] - testConstraint testevalobjv [llength [info commands testevalobjv]] - testConstraint testevalex [llength [info commands testevalex]] - testConstraint testparsevarname [llength [info commands testparsevarname]] - testConstraint testparsevar [llength [info commands testparsevar]] - testConstraint testasync [llength [info commands testasync]] - testConstraint testcmdtrace [llength [info commands testcmdtrace]] +testConstraint testparser [llength [info commands testparser]] +testConstraint testevalobjv [llength [info commands testevalobjv]] +testConstraint testevalex [llength [info commands testevalex]] +testConstraint testparsevarname [llength [info commands testparsevarname]] +testConstraint testparsevar [llength [info commands testparsevar]] +testConstraint testasync [llength [info commands testasync]] +testConstraint testcmdtrace [llength [info commands testcmdtrace]] test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser { testparser [bytestring "foo\0 bar"] -1 @@ -1045,7 +1042,7 @@ test parse-19.4 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup { interp delete i } -returnCodes error -match glob -result {too many nested*} - cleanupTests +cleanupTests } namespace delete ::tcl::test::parse diff --git a/tests/parseExpr.test b/tests/parseExpr.test index a397a6b..a72eb87 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: parseExpr.test,v 1.17 2005/11/09 20:24:11 dgp Exp $ +# RCS: @(#) $Id: parseExpr.test,v 1.18 2006/03/21 11:12:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -83,7 +83,7 @@ proc testIEEE {} { } } } -::tcltest::testConstraint ieeeFloatingPoint [testIEEE] +testConstraint ieeeFloatingPoint [testIEEE] ###################################################################### diff --git a/tests/parseOld.test b/tests/parseOld.test index 40413db..12317e1 100644 --- a/tests/parseOld.test +++ b/tests/parseOld.test @@ -13,15 +13,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: parseOld.test,v 1.12 2003/03/27 13:49:00 dkf Exp $ +# RCS: @(#) $Id: parseOld.test,v 1.13 2006/03/21 11:12:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -tcltest::testConstraint testwordend \ - [string equal "testwordend" [info commands testwordend]] +testConstraint testwordend [llength [info commands testwordend]] # Save the argv value for restoration later set savedArgv $argv diff --git a/tests/pkgMkIndex.test b/tests/pkgMkIndex.test index b7bd664..c71f087 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -8,7 +8,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: pkgMkIndex.test,v 1.27 2004/07/28 18:00:11 dgp Exp $ +# RCS: @(#) $Id: pkgMkIndex.test,v 1.28 2006/03/21 11:12:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -562,17 +562,17 @@ removeFile [file join pkg circ3.tcl] set x [file join [file dirname [info nameofexecutable]] dltest \ pkga[info sharedlibextension]] set dll "[file tail $x]Required" -::tcltest::testConstraint $dll [file exists $x] +testConstraint $dll [file exists $x] if {[testConstraint $dll]} { -makeFile { + makeFile { # This package provides Pkga, which is also provided by a DLL. package provide Pkga 1.0 proc pkga_neq { x } { return [expr {! [pkgq_eq $x]}] } } [file join pkg pkga.tcl] -file copy -force $x $fullPkgPath + file copy -force $x $fullPkgPath } testConstraint exec [llength [info commands ::exec]] @@ -598,8 +598,8 @@ test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] { } {0 {}} if {[testConstraint $dll]} { -file delete -force [file join $fullPkgPath [file tail $x]] -removeFile [file join pkg pkga.tcl] + file delete -force [file join $fullPkgPath [file tail $x]] + removeFile [file join pkg pkga.tcl] } # Tolerate "namespace import" at the global scope diff --git a/tests/registry.test b/tests/registry.test index 9d475e7..28027d5 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -10,34 +10,32 @@ # Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved. # Copyright (c) 1998-1999 by Scriptics Corporation. # -# RCS: @(#) $Id: registry.test,v 1.18 2004/10/27 20:53:37 davygrvy Exp $ +# RCS: @(#) $Id: registry.test,v 1.19 2006/03/21 11:12:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } -if {$tcl_platform(platform) == "windows"} { - if [catch { +testConstraint reg 0 +if {[testConstraint win]} { + catch { # Is the registry extension already static to this shell? if [catch {load {} Registry; set ::reglib {}}] { # try the location given to use on the commandline to tcltest ::tcltest::loadTestedCommands load $::reglib Registry } - ::tcltest::testConstraint reg 1 - }] { - ::tcltest::testConstraint reg 0 + testConstraint reg 1 } } # determine the current locale -testConstraint english [expr {[llength [info commands testlocale]] - && [string match "English*" [testlocale all ""]] +testConstraint english [expr { + [llength [info commands testlocale]] + && [string match "English*" [testlocale all ""]] }] -set hostname [info hostname] - test registry-1.1 {argument parsing for registry command} {win reg} { list [catch {registry} msg] $msg } {1 {wrong # args: should be "registry option ?arg arg ...?"}} @@ -202,6 +200,7 @@ test registry-4.2 {GetKeyNames} {win reg} { set result } {baz} test registry-4.3 {GetKeyNames: remote key} {win reg nonPortable english} { + set hostname [info hostname] registry set \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar\\baz set result [registry keys \\\\gaspode\\HKEY_CLASSES_ROOT\\TclFoobar] registry delete \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar @@ -471,6 +470,7 @@ test registry-7.3 {GetValueNames} {win reg} { set result } {{} baz blat} test registry-7.4 {GetValueNames: remote key} {win reg nonPortable english} { + set hostname [info hostname] registry set \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar baz blat set result [registry values \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar] registry delete \\\\$hostname\\HKEY_CLASSES_ROOT\\TclFoobar @@ -598,6 +598,5 @@ test registry-12.5 {BroadcastValue} {win reg} { } {0 {1 0}} # cleanup -unset hostname ::tcltest::cleanupTests return diff --git a/tests/safe.test b/tests/safe.test index 4def77c..9324398 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -10,7 +10,9 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: safe.test,v 1.19 2005/05/10 18:35:23 kennykb Exp $ +# RCS: @(#) $Id: safe.test,v 1.20 2006/03/21 11:12:29 dkf Exp $ + +package require Tcl 8.5 if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -156,28 +158,25 @@ test safe-5.1 {test auto-loading in safe interpreters} { } {0 -1} # test safe interps 'information leak' -proc SI {} { - global I - set I [interp create -safe]; -} -proc DI {} { - global I; - interp delete $I; +proc SafeEval {script} { + # Helper procedure that ensures the safe interp is cleaned up even if + # there is a failure in the script. + set SafeInterp [interp create -safe] + catch {$SafeInterp eval $script} msg opts + interp delete $SafeInterp + return -options $opts $msg } test safe-6.1 {test safe interpreters knowledge of the world} { - SI; set r [lsort [$I eval {info globals}]]; DI; set r + lsort [SaveEval {info globals}] } {tcl_interactive tcl_patchLevel tcl_platform tcl_version} test safe-6.2 {test safe interpreters knowledge of the world} { - SI; set r [$I eval {info script}]; DI; set r + SafeEval {info script} } {} test safe-6.3 {test safe interpreters knowledge of the world} { - SI - set r [lsort [$I eval {array names tcl_platform}]] - DI + set r [lsort [SafeEval {array names tcl_platform}]] # If running a windows-debug shell, remove the "debug" element from r. - if {$tcl_platform(platform) == "windows" && \ - [lsearch $r "debug"] != -1} { + if {[testConstraint win] && ("debug" in $r)} { set r [lreplace $r 1 1] } set threaded [lsearch $r "threaded"] diff --git a/tests/scan.test b/tests/scan.test index 5bc986c..e9ffad6 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -11,14 +11,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: scan.test,v 1.19 2005/12/19 19:03:17 dgp Exp $ +# RCS: @(#) $Id: scan.test,v 1.20 2006/03/21 11:12:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } -::tcltest::testConstraint wideIs64bit \ +testConstraint wideIs64bit \ [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] test scan-1.1 {BuildCharSet, CharInSet} { diff --git a/tests/source.test b/tests/source.test index 1d64034..29d3f2f 100644 --- a/tests/source.test +++ b/tests/source.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: source.test,v 1.12 2004/03/17 18:14:18 das Exp $ +# RCS: @(#) $Id: source.test,v 1.13 2006/03/21 11:12:29 dkf Exp $ if {[catch {package require tcltest 2.1}]} { puts stderr "Skipping tests in [info script]. tcltest 2.1 required." @@ -20,12 +20,7 @@ if {[catch {package require tcltest 2.1}]} { } namespace eval ::tcl::test::source { - namespace import ::tcltest::test - namespace import ::tcltest::testConstraint - namespace import ::tcltest::cleanupTests - namespace import ::tcltest::makeFile - namespace import ::tcltest::removeFile - namespace import ::tcltest::customMatch + namespace import ::tcltest::* test source-1.1 {source command} -setup { set x "old x value" @@ -42,7 +37,6 @@ test source-1.1 {source command} -setup { } -cleanup { removeFile source.file } -result {22 33 44} - test source-1.2 {source command} -setup { set sourcefile [makeFile {list result} source.file] } -body { @@ -50,7 +44,6 @@ test source-1.2 {source command} -setup { } -cleanup { removeFile source.file } -result result - test source-1.3 {source command} -setup { set sourcefile [makeFile {} source.file] set fd [open $sourcefile w] @@ -94,7 +87,6 @@ test source-2.3 {source error conditions} -setup { (file "*source.file" line 3) invoked from within "source $sourcefile"}] - test source-2.4 {source error conditions} -setup { set sourcefile [makeFile {break} source.file] } -body { @@ -102,7 +94,6 @@ test source-2.4 {source error conditions} -setup { } -cleanup { removeFile source.file } -returnCodes break - test source-2.5 {source error conditions} -setup { set sourcefile [makeFile {continue} source.file] } -body { @@ -110,7 +101,6 @@ test source-2.5 {source error conditions} -setup { } -cleanup { removeFile source.file } -returnCodes continue - test source-2.6 {source error conditions} -setup { set sourcefile [makeFile {} _non_existent_] removeFile _non_existent_ @@ -120,7 +110,6 @@ test source-2.6 {source error conditions} -setup { {couldn't read file "*_non_existent_": no such file or directory} \ {POSIX ENOENT {no such file or directory}}] - test source-3.1 {return in middle of source file} -setup { set sourcefile [makeFile { set x new-x @@ -135,7 +124,6 @@ test source-3.1 {return in middle of source file} -setup { } -cleanup { removeFile source.file } -result {new-x old-y allDone} - test source-3.2 {return with special code etc.} -setup { set sourcefile [makeFile { set x new-x @@ -147,7 +135,6 @@ test source-3.2 {return with special code etc.} -setup { } -cleanup { removeFile source.file } -returnCodes break -result {Silly result} - test source-3.3 {return with special code etc.} -setup { set sourcefile [makeFile { set x new-x @@ -161,7 +148,6 @@ test source-3.3 {return with special code etc.} -setup { } -result {1 {Simulated error} {Simulated error while executing "source $sourcefile"} NONE} - test source-3.4 {return with special code etc.} -setup { set sourcefile [makeFile { set x new-x @@ -175,7 +161,6 @@ test source-3.4 {return with special code etc.} -setup { } -result {1 {} {Simulated errorInfo stuff invoked from within "source $sourcefile"} NONE} - test source-3.5 {return with special code etc.} -setup { set sourcefile [makeFile { set x new-x @@ -191,7 +176,6 @@ test source-3.5 {return with special code etc.} -setup { invoked from within "source $sourcefile"} {a b c}} - test source-6.1 {source is binary ok} -setup { # Note [makeFile] writes in the system encoding. # [source] defaults to reading in the system encoding. @@ -203,7 +187,6 @@ test source-6.1 {source is binary ok} -setup { } -cleanup { removeFile source.file } -result 5 - test source-6.2 {source skips everything after Ctrl-Z: Bug 2040} -setup { set sourcefile [makeFile "set x ab\32c" source.file] } -body { @@ -228,7 +211,6 @@ test source-7.1 {source -encoding test} -setup { } -cleanup { removeFile source.file } -result correct - test source-7.2 {source -encoding test} -setup { # This tests for bad interactions between [source -encoding] # and use of the Control-Z character (\u001A) as a cross-platform @@ -248,12 +230,10 @@ test source-7.2 {source -encoding test} -setup { } -cleanup { removeFile source.file } -result correct - test source-7.3 {source -encoding: syntax} -body { # Have to spell out the -encoding option source -e utf-8 no_file } -returnCodes 1 -match glob -result {bad option*} - test source-7.4 {source -encoding: syntax} -setup { set sourcefile [makeFile {} source.file] } -body { @@ -261,7 +241,6 @@ test source-7.4 {source -encoding: syntax} -setup { } -cleanup { removeFile source.file } -returnCodes 1 -match glob -result {unknown encoding*} - test source-7.5 {source -encoding: correct operation} -setup { set sourcefile [makeFile {} source.file] file delete $sourcefile @@ -276,7 +255,6 @@ test source-7.5 {source -encoding: correct operation} -setup { removeFile source.file rename \u20ac {} } -result foo - test source-7.6 {source -encoding: mismatch encoding error} -setup { set sourcefile [makeFile {} source.file] file delete $sourcefile diff --git a/tests/stack.test b/tests/stack.test index 64b669a..047e0e8 100644 --- a/tests/stack.test +++ b/tests/stack.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: stack.test,v 1.18 2004/06/23 00:24:43 dkf Exp $ +# RCS: @(#) $Id: stack.test,v 1.19 2006/03/21 11:12:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -23,19 +23,16 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # This doesn't catch all cases, for example threads of lower stacksize # can still squeak through. A core check is really needed. -- JH -if {[string equal $::tcl_platform(platform) "unix"]} { +testConstraint minStack2400 1 +if {[testConstraint unix]} { set stackSize [exec /bin/sh -c "ulimit -s"] if {[string is integer $stackSize] && ($stackSize < 2400)} { puts stderr "WARNING: the default application stacksize of $stackSize\ may cause Tcl to\ncrash due to stack overflow before the\ recursion limit is reached.\nA minimum stacksize of 2400\ kbytes is recommended.\nSkipping infinite recursion test." - ::tcltest::testConstraint minStack2400 0 - } else { - ::tcltest::testConstraint minStack2400 1 + testConstraint minStack2400 0 } -} else { - ::tcltest::testConstraint minStack2400 1 } test stack-1.1 {maxNestingDepth reached on infinite recursion} {minStack2400} { diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index 2cf71f1..20afe69 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: unixFCmd.test,v 1.23 2006/03/20 14:24:09 dgp Exp $ +# RCS: @(#) $Id: unixFCmd.test,v 1.24 2006/03/21 11:12:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -25,7 +25,7 @@ cd [temporaryDirectory] # Several tests require need to match results against the unix username set user {} -if {$tcl_platform(platform) == "unix"} { +if {[testConstraint unix]} { catch {set user [exec whoami]} if {$user == ""} { catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user} @@ -35,6 +35,28 @@ if {$tcl_platform(platform) == "unix"} { } } +# Find a group that exists on this system, or else skip tests that require +# groups +testConstraint foundGroup 0 +if {[testConstraint unix]} { + catch { + set groupList [exec groups] + set group [lindex $groupList 0] + testConstraint foundGroup 1 + } +} + +# check whether -readonly attribute is supported +testConstraint readonlyAttr 0 +if {[testConstraint unix]} { + set f [makeFile "whatever" probe] + catch { + file attributes $f -readonly + testConstraint readonlyAttr 1 + } + removeFile probe +} + proc openup {path} { testchmod 777 $path if {[file isdirectory $path]} { @@ -125,6 +147,7 @@ test unixFCmd-1.9 {Checking EINTR Bug} {unix notRoot nonPortable} { catch {close $pipe} list $line [testgotsig] } {h 1} + test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} \ {unix notRoot} { cleanup @@ -232,17 +255,6 @@ test unixFCmd-14.2 {GetPermissionsAttribute} {unix notRoot} { [file delete -force -- foo.test] } {0 {}} -# Find a group that exists on this system, or else skip tests that require -# groups -testConstraint foundGroup 0 -if {$tcl_platform(platform) == "unix"} { - catch { - set groupList [exec groups] - set group [lindex $groupList 0] - testConstraint foundGroup 1 - } -} - #groups hard to test test unixFCmd-15.1 {SetGroupAttribute - invalid group} {unix notRoot} { catch {file delete -force -- foo.test} @@ -330,17 +342,6 @@ test unixFCmd-18.1 {Unix pwd} {nonPortable unix notRoot} { set r } {1 {error getting working directory name:}} -# check whether -readonly attribute is supported -testConstraint readonlyAttr 0 -if {$tcl_platform(platform) == "unix"} { - set f [makeFile "whatever" probe] - catch { - file attributes $f -readonly - testConstraint readonlyAttr 1 - } - removeFile probe -} - test unixFCmd-19.1 {GetReadOnlyAttribute - file not found} {unix notRoot readonlyAttr} { catch {file delete -force -- foo.test} list [catch {file attributes foo.test -readonly} msg] $msg diff --git a/tests/unixInit.test b/tests/unixInit.test index d2ebbfb..4c876c4 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.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: unixInit.test,v 1.48 2005/05/10 18:35:24 kennykb Exp $ +# RCS: @(#) $Id: unixInit.test,v 1.49 2006/03/21 11:12:29 dkf Exp $ package require tcltest 2.2 namespace import -force ::tcltest::* @@ -20,27 +20,22 @@ set env(LANG) C test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} { set x {} - # Watch out for a race condition here. If tcltest is too slow to start # then we'll kill it before it has a chance to set up its signal handler. - set f [open "|[list [interpreter]]" w+] puts $f "puts hi" flush $f gets $f exec kill -PIPE [pid $f] lappend x [catch {close $f}] - set f [open "|[list [interpreter]]" w+] puts $f "puts hi" flush $f gets $f exec kill [pid $f] lappend x [catch {close $f}] - set x } {0 1} - # This test is really a test of code in tclUnixChan.c, but the # channels are set up as part of initialisation of the interpreter so # the test seems to me to fit here as well as anywhere else. @@ -70,16 +65,13 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} # as a socket. Which is what this test is all about. set pipe2 [open "|[list [interpreter] <@$sock]" r] set result [gets $pipe2] - # Clear any pending data; stops certain kinds of (non-important) errors fconfigure $pipe1 -blocking 0; gets $pipe1 fconfigure $pipe2 -blocking 0; gets $pipe2 - # Close the pipes and the socket. close $pipe2 close $pipe1 catch {close $sock} - # Can't use normal comparison, as hostname varies due to some # installations having a messed up /etc/hosts file. if { @@ -105,7 +97,6 @@ test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} { testsetdefenc $origDir set path } {slappy} - test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { @@ -114,11 +105,9 @@ test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} -setup } } -body { set path [getlibpath] - set installLib lib/tcl[info tclversion] set developLib tcl[info patchlevel]/library set prefix [file dirname [file dirname [interpreter]]] - set x {} lappend x [string compare [lindex $path 0] $prefix/$installLib] lappend x [string compare [lindex $path 4] [file dirname $prefix]/$developLib] @@ -129,19 +118,16 @@ test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} -setup unset oldlibrary } } -result {0 0} - test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) } } -body { - # ((str != NULL) && (str[0] != '\0')) - + # ((str != NULL) && (str[0] != '\0')) set env(TCL_LIBRARY) sparkly set path [getlibpath] unset env(TCL_LIBRARY) - lindex $path 0 } -cleanup { if {[info exists oldlibrary]} { @@ -149,7 +135,6 @@ test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} -setup { unset oldlibrary } } -result "sparkly" - test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { @@ -157,11 +142,9 @@ test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} -setup { } } -body { # ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0)) - set env(TCL_LIBRARY) /a/b/tcl1.7 set path [getlibpath] unset env(TCL_LIBRARY) - lrange $path 0 1 } -cleanup { if {[info exists oldlibrary]} { @@ -169,19 +152,16 @@ test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} -setup { unset oldlibrary } } -result [list /a/b/tcl1.7 /a/b/tcl[info tclversion]] - test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} -setup { if {[info exists env(TCL_LIBRARY)]} { set oldlibrary $env(TCL_LIBRARY) } } -body { # Child process translates env variable from native encoding. - set env(TCL_LIBRARY) "\xa7" set x [lindex [getlibpath] 0] unset env(TCL_LIBRARY) unset env(LANG) - set x } -cleanup { if {[info exists oldlibrary]} { @@ -192,7 +172,6 @@ test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} -setup { test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} { # cannot test } {} - test unixInit-2.6 {TclpInitLibraryPath: executable relative} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { @@ -223,12 +202,10 @@ test unixInit-2.6 {TclpInitLibraryPath: executable relative} -setup { unset oldlibrary } } -result [list [temporaryDirectory]/tmp/sparkly/lib/tcl[info tclversion] [temporaryDirectory]/tmp/lib/tcl[info tclversion]] - test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} { # would need test command to get defaultLibDir and compare it to # [lindex $auto_path end] } {} - # # The following two tests write to the directory /tmp/sparkly instead # of to [temporaryDirectory]. This is because the failures tested by @@ -260,7 +237,6 @@ test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} -setup { file delete -force /tmp/lib/tcl[info tclversion] file mkdir /tmp/sparkly file copy [interpreter] /tmp/sparkly/tcltest - # Keep any existing /tmp/lib directory set deletelib 1 if {[file exists /tmp/lib]} { @@ -270,13 +246,11 @@ test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} -setup { file delete -force /tmp/lib } } - # For a successful Tcl_Init, we need a [source]-able init.tcl in # ../lib/tcl$version relative to the executable. file mkdir /tmp/lib/tcl[info tclversion] close [open /tmp/lib/tcl[info tclversion]/init.tcl w] } -body { - # Check that all directories in the library path are absolute pathnames set allAbsolute 1 foreach dir [getlibpath /tmp/sparkly/tcltest] { @@ -285,7 +259,6 @@ test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} -setup { } set allAbsolute } -cleanup { - # Clean up temporary installation file delete -force /tmp/sparkly file delete -force /tmp/lib/tcl[info tclversion] @@ -296,7 +269,6 @@ test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} -setup { unset oldlibrary } } -result 1 - test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} -setup { # Checking for Bug 438014 unset -nocomplain oldlibrary @@ -308,7 +280,6 @@ test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} -setup { file delete -force /tmp/library file mkdir /tmp/sparkly file copy [interpreter] /tmp/sparkly/tcltest - file mkdir /tmp/library/ close [open /tmp/library/init.tcl w] } -body { @@ -323,7 +294,6 @@ test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} -setup { } } -result [list /tmp/lib/tcl[info tclversion] /lib/tcl[info tclversion] \ /tmp/library /library /tcl[info patchlevel]/library] - test unixInit-2.10 {TclpInitLibraryPath: executable relative} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { @@ -374,23 +344,19 @@ test unixInit-3.1 {TclpSetInitialEncodings} -constraints { unix stdio } -body { set env(LANG) C - set f [open "|[list [interpreter]]" w+] fconfigure $f -buffering none puts $f {puts [encoding system]; exit} set enc [gets $f] close $f unset env(LANG) - set enc } -match regexp -result [expr { ($tcl_platform(os) eq "Darwin") ? "^utf-8$" : "^iso8859-15?$"}] - test unixInit-3.2 {TclpSetInitialEncodings} {unix stdio} { set env(LANG) japanese catch {set oldlc_all $env(LC_ALL)} set env(LC_ALL) japanese - set f [open "|[list [interpreter]]" w+] fconfigure $f -buffering none puts $f {puts [encoding system]; exit} @@ -399,7 +365,6 @@ test unixInit-3.2 {TclpSetInitialEncodings} {unix stdio} { unset env(LANG) unset env(LC_ALL) catch {set env(LC_ALL) $oldlc_all} - set validEncodings [list euc-jp] if {[string match HP-UX $tcl_platform(os)]} { # Some older HP-UX systems need us to accept this as valid @@ -409,10 +374,9 @@ test unixInit-3.2 {TclpSetInitialEncodings} {unix stdio} { } expr {[lsearch -exact $validEncodings $enc] < 0} } 0 - + test unixInit-4.1 {TclpSetVariables} {unix} { # just make sure they exist - set a [list $tcl_library $tcl_pkgPath $tcl_platform(os)] set a [list $tcl_platform(osVersion) $tcl_platform(machine)] set tcl_platform(platform) @@ -426,7 +390,7 @@ test unixInit-6.1 {Tcl_SourceRCFile} {emptyTest unix} { } {} test unixInit-7.1 {closed standard channel: Bug 772288} -constraints { - unix stdio + unix stdio } -body { set tclsh [interpreter] set crash [makeFile {puts [open /dev/null]} crash.tcl] diff --git a/tests/unload.test b/tests/unload.test index 6cc0007..8af0672 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: unload.test,v 1.4 2004/05/25 19:38:16 dgp Exp $ +# RCS: @(#) $Id: unload.test,v 1.5 2006/03/21 11:12:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -26,19 +26,17 @@ set ext [info sharedlibextension] set testDir [file join [file dirname [info nameofexecutable]] dltest] set x [file join $testDir pkgua$ext] set dll "[file tail $x]Required" -::tcltest::testConstraint $dll [file readable $x] +testConstraint $dll [file readable $x] # Tests also require that this DLL has not already been loaded. set loaded "[file tail $x]Loaded" set alreadyLoaded [info loaded] -::tcltest::testConstraint $loaded \ - [expr {![string match *pkgua* $alreadyLoaded]}] +testConstraint $loaded [expr {![string match *pkgua* $alreadyLoaded]}] set alreadyTotalLoaded [info loaded] # Certain tests require the 'teststaticpkg' command from tcltest -::tcltest::testConstraint teststaticpkg \ - [string compare {} [info commands teststaticpkg]] +testConstraint teststaticpkg [llength [info commands teststaticpkg]] # Basic tests: parameter testing... test unload-1.1 {basic errors} {} { diff --git a/tests/util.test b/tests/util.test index da243cd..8c1ef26 100644 --- a/tests/util.test +++ b/tests/util.test @@ -7,13 +7,15 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: util.test,v 1.17 2005/05/12 22:48:18 dgp Exp $ +# RCS: @(#) $Id: util.test,v 1.18 2006/03/21 11:12:29 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } +testConstraint testdstring [llength [info commands testdstring]] + # Big test for correct ordering of data in [expr] proc testIEEE {} { @@ -70,7 +72,7 @@ proc testIEEE {} { } } } -::tcltest::testConstraint ieeeFloatingPoint [testIEEE] +testConstraint ieeeFloatingPoint [testIEEE] proc convertDouble { x } { variable ieeeValues @@ -82,6 +84,7 @@ proc convertDouble { x } { return $result } + test util-1.1 {TclFindElement procedure - binary element in middle of list} { lindex {0 foo\x00help 1} 1 } "foo\x00help" @@ -102,7 +105,6 @@ test util-3.1 {Tcl_ScanCountedElement procedure - don't leave unmatched braces} # have the property that it can be enclosing in curly braces to make # an embedded sub-list. If this property doesn't hold, then # Tcl_DStringStartSublist doesn't work. - set x {} lappend x "# \\\{ \\" concat $x [llength "{$x}"] @@ -141,6 +143,7 @@ test util-3.5.1 {Tcl_ConverCountedElement procedure - quote leading '#'} { rename #\{ {} set result } {#} + test util-4.1 {Tcl_ConcatObj - backslash-space at end of argument} { concat a {b\ } c } {a b\ c} @@ -191,7 +194,6 @@ test util-5.8 {Tcl_StringMatch} { } 1 test util-5.9 {Tcl_StringMatch: UTF-8} { # skip one character in string - Wrapper_Tcl_StringMatch a?c a\u4e4fc } 1 test util-5.10 {Tcl_StringMatch} { @@ -205,19 +207,16 @@ test util-5.12 {Tcl_StringMatch} { } 1 test util-5.13 {Tcl_StringMatch: UTF-8} { # string += Tcl_UtfToUniChar(string, &ch); - Wrapper_Tcl_StringMatch "\[\u4e4fxy\]bc" "\u4e4fbc" } 1 test util-5.14 {Tcl_StringMatch} { # if ((*pattern == ']') || (*pattern == '\0')) # badly formed pattern - Wrapper_Tcl_StringMatch {[]} {[]} } 0 test util-5.15 {Tcl_StringMatch} { # if ((*pattern == ']') || (*pattern == '\0')) # badly formed pattern - Wrapper_Tcl_StringMatch {[} {[} } 0 test util-5.16 {Tcl_StringMatch} { @@ -226,19 +225,16 @@ test util-5.16 {Tcl_StringMatch} { test util-5.17 {Tcl_StringMatch: UTF-8} { # pattern += Tcl_UtfToUniChar(pattern, &endChar); # get 1 UTF-8 character - Wrapper_Tcl_StringMatch "a\[a\u4e4fc]c" "a\u4e4fc" } 1 test util-5.18 {Tcl_StringMatch: UTF-8} { # pattern += Tcl_UtfToUniChar(pattern, &endChar); # proper advance: wrong answer would match on UTF trail byte of \u4e4f - Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [bytestring a\u008fc] } 0 test util-5.19 {Tcl_StringMatch: UTF-8} { # pattern += Tcl_UtfToUniChar(pattern, &endChar); # proper advance. - Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} "acc" } 1 test util-5.20 {Tcl_StringMatch} { @@ -319,7 +315,6 @@ test util-5.44 {Tcl_StringMatch: skip correct number of ']'} { test util-5.45 {Tcl_StringMatch} { # if (*pattern == '\0') # badly formed pattern, still treats as a set - Wrapper_Tcl_StringMatch {[a} a } 1 test util-5.46 {Tcl_StringMatch} { @@ -373,7 +368,6 @@ test util-6.4 {Tcl_PrintDouble - using tcl_precision} -setup { } -cleanup { set tcl_precision $old_precision } -result {x1.1234} - test util-6.5 {Tcl_PrintDouble - make sure there's a decimal point} { concat x[expr 2.0] } {x2.0} @@ -440,9 +434,6 @@ test util-8.1 {TclNeedSpace - correct UTF8 handling} { interp delete \u5420 set result } "\u5420 foo" - -testConstraint testdstring [expr {[info commands testdstring] != {}}] - test util-8.2 {TclNeedSpace - correct UTF8 handling} testdstring { # Bug 411825 # This tests the same bug as the previous test, but |