diff options
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 |