diff options
Diffstat (limited to 'tests')
55 files changed, 4222 insertions, 555 deletions
diff --git a/tests/all.tcl b/tests/all.tcl index 69a16ba..e14bd9c 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -13,10 +13,14 @@ package prefer latest package require Tcl 8.5- package require tcltest 2.2 -namespace import tcltest::* -configure {*}$argv -testdir [file dir [info script]] +namespace import ::tcltest::* + +configure {*}$argv -testdir [file dirname [file dirname [file normalize [ + info script]/...]]] + if {[singleProcess]} { interp debug {} -frame 1 } + runAllTests proc exit args {} diff --git a/tests/async.test b/tests/async.test index 6de814b..34c2fdc 100644 --- a/tests/async.test +++ b/tests/async.test @@ -156,17 +156,24 @@ test async-4.1 {async interrupting bytecode sequence} -constraints { } } -body { apply {{handle} { - global aresult - set aresult {Async event not delivered} - testasync marklater $handle - for {set i 0} { - $i < 2500000 && $aresult eq "Async event not delivered" - } {incr i} { - nothing - } + global aresult + set aresult {Async event not delivered} + testasync marklater $handle + # allow plenty of time to pass in case valgrind is running + set start [clock seconds] + while { + [clock seconds] - $start < 180 && $aresult eq "Async event not delivered" + } { + # be less busy + after 100 + nothing + } return $aresult }} $hm } -result {test pattern} -cleanup { + # give other threads some time to go way so that valgrind doesn't pick up + # "still reachable" cases from early thread termination + after 100 testasync delete $hm } test async-4.2 {async interrupting straight bytecode sequence} -constraints { @@ -178,12 +185,20 @@ test async-4.2 {async interrupting straight bytecode sequence} -constraints { global aresult set aresult {Async event not delivered} testasync marklater $handle - for {set i 0} { - $i < 2500000 && $aresult eq "Async event not delivered" - } {incr i} {} + # allow plenty of time to pass in case valgrind is running + set start [clock seconds] + while { + [clock seconds] - $start < 180 && $aresult eq "Async event not delivered" + } { + # be less busy + after 100 + } return $aresult }} $hm } -result {test pattern} -cleanup { + # give other threads some time to go way so that valgrind doesn't pick up + # "still reachable" cases from early thread termination + after 100 testasync delete $hm } test async-4.3 {async interrupting loop-less bytecode sequence} -constraints { @@ -200,6 +215,9 @@ test async-4.3 {async interrupting loop-less bytecode sequence} -constraints { return $aresult }]] $hm } -result {test pattern} -cleanup { + # give other threads some time to go way so that valgrind doesn't pick up + # "still reachable" cases from early thread termination + after 100 testasync delete $hm } diff --git a/tests/binary.test b/tests/binary.test index 1ee815b..54e8e94 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -1647,22 +1647,6 @@ test binary-43.2 {Tcl_BinaryObjCmd: format wide int} {} { binary format W 7810179016327718216 } lcTolleH -test binary-44.1 {Tcl_BinaryObjCmd: scan wide int} {} { - binary scan HelloTcl W x - set x -} 5216694956358656876 -test binary-44.2 {Tcl_BinaryObjCmd: scan wide int} {} { - binary scan lcTolleH w x - set x -} 5216694956358656876 -test binary-44.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} { - binary scan [binary format w [expr {wide(3) << 31}]] w x - set x -} 6442450944 -test binary-44.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} { - binary scan [binary format W [expr {wide(3) << 31}]] W x - set x -} 6442450944 test binary-43.5 {Tcl_BinaryObjCmd: scan wide int} {} { unset -nocomplain arg1 list [binary scan \x80[string repeat \x00 7] W arg1] $arg1 @@ -1684,6 +1668,31 @@ test binary-43.9 {Tcl_BinaryObjCmd: scan unsigned wide int} {} { list [binary scan [string repeat \x00 7]\x80[string repeat \x00 7]\x80 wuw arg1 arg2] $arg1 $arg2 } {2 9223372036854775808 -9223372036854775808} +test binary-44.1 {Tcl_BinaryObjCmd: scan wide int} {} { + binary scan HelloTcl W x + set x +} 5216694956358656876 +test binary-44.2 {Tcl_BinaryObjCmd: scan wide int} {} { + binary scan lcTolleH w x + set x +} 5216694956358656876 +test binary-44.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} { + binary scan [binary format w [expr {wide(3) << 31}]] w x + set x +} 6442450944 +test binary-44.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} { + binary scan [binary format W [expr {wide(3) << 31}]] W x + set x +} 6442450944 +test binary-44.5 {Tcl_BinaryObjCmd: scan wide int with bit 31 and 64 set} {} { + binary scan [binary format w [expr {(wide(3) << 31) + (wide(3) << 64)}]] w x + set x +} 6442450944 +test binary-44.6 {Tcl_BinaryObjCmd: scan wide int with bit 31 and 64 set} {} { + binary scan [binary format W [expr {(wide(3) << 31) + (wide(3) << 64)}]] W x + set x +} 6442450944 + test binary-45.1 {Tcl_BinaryObjCmd: combined wide int handling} { binary scan [binary format sws 16450 -1 19521] c* x set x diff --git a/tests/chanio.test b/tests/chanio.test index 97e7e70..300c54a 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -13,16 +13,11 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. +# TODO: This test is likely worthless. Confirm and remove if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 - namespace import -force ::tcltest::* } -::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] - -testConstraint testbytestring [llength [info commands testbytestring]] - namespace eval ::tcl::test::io { namespace import ::tcltest::* @@ -35,18 +30,16 @@ namespace eval ::tcl::test::io { variable msg variable expected - ::tcltest::loadTestedCommands + loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] + package require tcltests + testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] - testConstraint exec [llength [info commands exec]] testConstraint openpipe 1 - testConstraint fileevent [llength [info commands fileevent]] - 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 thread [expr {0 == [catch {package require Thread 2.7-}]}] # You need a *very* special environment to do some tests. In particular, # many file systems do not support large-files... @@ -5964,7 +5957,7 @@ test chan-io-48.3 {testing readability conditions} -setup { chan close $f } -result {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}} unset path(bar) -removeFile bar +removeFile bar test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode} -setup { file delete $path(test1) diff --git a/tests/cmdAH.test b/tests/cmdAH.test index e334dff..e8933d6 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -23,7 +23,7 @@ testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint linkDirectory [expr { ![testConstraint win] || - ([string index $tcl_platform(osVersion) 0] >= 5 + ($::tcl_platform(osVersion) >= 5.0 && [lindex [file system [temporaryDirectory]] 1] eq "NTFS") }] @@ -1040,7 +1040,7 @@ test cmdAH-20.7.1 { Tcl_FileObjCmd: atime (built-in Windows names with dir path and extension) } -constraints {win} -body { file atime [file join [temporaryDirectory] CON.txt] -} -result "could not get access time for file \"[file join [temporaryDirectory] CON.txt]\"" -returnCodes error +} -match regexp -result {could not (?:get access time|read)} -returnCodes error if {[testConstraint unix] && [file exists /tmp]} { removeFile touch.me /tmp @@ -1281,7 +1281,7 @@ test cmdAH-24.14.1 { Tcl_FileObjCmd: mtime (built-in Windows names with dir path and extension) } -constraints {win} -body { file mtime [file join [temporaryDirectory] CON.txt] -} -result "could not get modification time for file \"[file join [temporaryDirectory] CON.txt]\"" -returnCodes error +} -match regexp -result {could not (?:get modification time|read)} -returnCodes error # owned test cmdAH-25.1 {Tcl_FileObjCmd: owned} -returnCodes error -body { @@ -1345,7 +1345,12 @@ test cmdAH-27.4 { test cmdAH-27.4.1 { Tcl_FileObjCmd: size (built-in Windows names with dir path and extension) } -constraints {win} -body { - file size [file join [temporaryDirectory] con.txt] + try { + set res [file size [file join [temporaryDirectory] con.txt]] + } trap {POSIX ENOENT} {} { + set res 0 + } + set res } -result 0 catch {testsetplatform $platform} @@ -1447,8 +1452,13 @@ test cmdAH-28.13 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints {w test cmdAH-28.13.1 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints {win} -setup { unset -nocomplain stat } -body { - file stat [file join [temporaryDirectory] CON.txt] stat - lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)} + try { + file stat [file join [temporaryDirectory] CON.txt] stat + set res [lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)}] + } trap {POSIX ENOENT} {} { + set res {0 0 -1 0 0 8630 0 0 0 characterSpecial 0} + } + set res } -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0} unset -nocomplain stat @@ -1498,7 +1508,12 @@ test cmdAH-29.6 { test cmdAH-29.6.1 { Tcl_FileObjCmd: type (built-in Windows names, with dir path and extension) } -constraints {win} -body { - file type [file join [temporaryDirectory] CON.txt] + try { + set res [file type [file join [temporaryDirectory] CON.txt]] + } trap {POSIX ENOENT} {} { + set res {characterSpecial} + } + set res } -result "characterSpecial" # Error conditions diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index 0136ccd..e57f799 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -78,8 +78,8 @@ proc testIEEE {} { } testConstraint ieeeFloatingPoint [testIEEE] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] # procedures used below @@ -331,16 +331,9 @@ test compExpr-old-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12 test compExpr-old-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63 test compExpr-old-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1 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 - -test compExpr-old-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit { +test compExpr-old-9.5 {CompileRelationalExpr: large shift expr} { expr {int(1<<63)} -} -9223372036854775808 -test compExpr-old-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit { - expr {int(1<<31)} -} -2147483648 +} 9223372036854775808 test compExpr-old-9.6 {CompileRelationalExpr: error in shift expr} -body { expr x>>3 diff --git a/tests/config.test b/tests/config.test index d14837e..468a1df 100644 --- a/tests/config.test +++ b/tests/config.test @@ -19,7 +19,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { test pkgconfig-1.1 {query keys} { lsort [::tcl::pkgconfig list] -} {64bit bindir,install bindir,runtime compile_debug compile_stats debug docdir,install docdir,runtime includedir,install includedir,runtime libdir,install libdir,runtime mem_debug optimized profiled scriptdir,install scriptdir,runtime threaded} +} {64bit bindir,install bindir,runtime compile_debug compile_stats debug dllfile,runtime docdir,install docdir,runtime includedir,install includedir,runtime libdir,install libdir,runtime mem_debug optimized profiled scriptdir,install scriptdir,runtime threaded zipfile,runtime} test pkgconfig-1.2 {query keys multiple times} { string compare [::tcl::pkgconfig list] [::tcl::pkgconfig list] } 0 diff --git a/tests/env.test b/tests/env.test index 0dd4f98..79a353a 100644 --- a/tests/env.test +++ b/tests/env.test @@ -16,49 +16,98 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } -# Some tests require the "exec" command. -# Skip them if exec is not defined. -testConstraint exec [llength [info commands exec]] +loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] +package require tcltests + +# [exec] is required here to see the actual environment received by child +# processes. +proc getenv {} { + global printenvScript + catch {exec [interpreter] $printenvScript} out + if {$out eq "child process exited abnormally"} { + set out {} + } + return $out +} + + +proc envrestore {} { + # Restore the environment variables at the end of the test. + global env + variable env2 + + foreach name [array names env] { + unset env($name) + } + array set env $env2 + return +} + + +proc envprep {} { + # Save the current environment variables at the start of the test. + global env + variable keep + variable env2 + + set env2 [array get env] + foreach name [array names env] { + # Keep some environment variables that support operation of the tcltest + # package. + if {[string toupper $name] ni [string toupper $keep]} { + unset env($name) + } + } + return +} + + +proc encodingrestore {} { + variable sysenc + encoding system $sysenc + return +} + + +proc encodingswitch encoding { + variable sysenc + # Need to run [getenv] in known encoding, so save the current one here... + set sysenc [encoding system] + encoding system $encoding + return +} + + +proc setup1 {} { + global env + envprep + encodingswitch iso8859-1 +} + +proc setup2 {} { + global env + setup1 + set env(NAME1) {test string} + set env(NAME2) {new value} + set env(XYZZY) {garbage} +} + + +proc cleanup1 {} { + encodingrestore + envrestore +} -# -# These tests will run on any platform (and indeed crashed on the Mac). So put -# them before you test for the existance of exec. -# -test env-1.1 {propagation of env values to child interpreters} -setup { - catch {interp delete child} - catch {unset env(test)} -} -body { - interp create child - set env(test) garbage - child eval {set env(test)} -} -cleanup { - interp delete child - unset env(test) -} -result {garbage} -# -# This one crashed on Solaris under Tcl8.0, so we only want to make sure it -# runs. -# -test env-1.2 {lappend to env value} -setup { - catch {unset env(test)} -} -body { - set env(test) aaaaaaaaaaaaaaaa - append env(test) bbbbbbbbbbbbbb - unset env(test) +variable keep { + TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY + SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH + DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING + __CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM + CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432 } -test env-1.3 {reflection of env by "array names"} -setup { - catch {interp delete child} - catch {unset env(test)} -} -body { - interp create child - child eval {set env(test) garbage} - expr {"test" in [array names env]} -} -cleanup { - interp delete child - catch {unset env(test)} -} -result {1} -set printenvScript [makeFile { +variable printenvScript [makeFile [string map [list @keep@ [list $keep]] { encoding system iso8859-1 proc lrem {listname name} { upvar $listname list @@ -70,7 +119,7 @@ set printenvScript [makeFile { } proc mangle s { regsub -all {\[|\\|\]} $s {\\&} s - regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar &]} s + regsub -all "\[\u0000-\u001f\u007f-\uffff\]" $s {[manglechar {&}]} s return [subst -novariables $s] } proc manglechar c { @@ -84,161 +133,154 @@ set printenvScript [makeFile { lrem names ComSpec lrem names "" } - foreach name { - TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY - SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH - DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING - __CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM - CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432 - } { + foreach name @keep@ { lrem names $name } foreach p $names { - puts "[mangle $p]=[mangle $env($p)]" + puts [mangle $p]=[mangle $env($p)] } exit -} printenv] +}] printenv] -# [exec] is required here to see the actual environment received by child -# processes. -proc getenv {} { - global printenvScript tcltest - catch {exec [interpreter] $printenvScript} out - if {$out eq "child process exited abnormally"} { - set out {} - } - return $out -} -# Save the current environment variables at the start of the test. - -set env2 [array get env] -foreach name [array names env] { - # Keep some environment variables that support operation of the tcltest - # package. - if {[string toupper $name] ni { - TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH - SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH - DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING - SECURITYSESSIONID LANG WINDIR TERM - CONNOMPROGRAMFILES PROGRAMFILES COMMONPROGRAMW6432 PROGRAMW6432 - }} { - unset env($name) - } +test env-1.1 {propagation of env values to child interpreters} -setup { + catch {interp delete child} + catch {unset env(test)} +} -body { + interp create child + set env(test) garbage + child eval {set env(test)} +} -cleanup { + interp delete child + unset env(test) +} -result {garbage} + + +# This one crashed on Solaris under Tcl8.0, so we only want to make sure it +# runs. +test env-1.2 {lappend to env value} -setup { + catch {unset env(test)} +} -body { + set env(test) aaaaaaaaaaaaaaaa + append env(test) bbbbbbbbbbbbbb + unset env(test) } -# Need to run 'getenv' in known encoding, so save the current one here... -set sysenc [encoding system] -test env-2.1 {adding environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { - getenv +test env-1.3 {reflection of env by "array names"} -setup { + catch {interp delete child} + catch {unset env(test)} +} -body { + interp create child + child eval {set env(test) garbage} + expr {"test" in [array names env]} } -cleanup { - encoding system $sysenc -} -result {} -test env-2.2 {adding environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { + interp delete child + catch {unset env(test)} +} -result 1 + + +test env-2.1 { + adding environment variables +} -constraints exec -setup setup1 -body { + getenv +} -cleanup cleanup1 -result {} + + +test env-2.2 { + adding environment variables +} -constraints exec -setup setup1 -body { set env(NAME1) "test string" getenv -} -cleanup { - encoding system $sysenc -} -result {NAME1=test string} -test env-2.3 {adding environment variables} -setup { - encoding system iso8859-1 +} -cleanup cleanup1 -result {NAME1=test string} + + +test env-2.3 {adding environment variables} -constraints exec -setup { + setup1 set env(NAME1) "test string" -} -constraints {exec} -body { +} -body { set env(NAME2) "more" getenv -} -cleanup { - encoding system $sysenc -} -result {NAME1=test string +} -cleanup cleanup1 -result {NAME1=test string NAME2=more} -test env-2.4 {adding environment variables} -setup { - encoding system iso8859-1 + + +test env-2.4 { + adding environment variables +} -constraints exec -setup { + setup1 set env(NAME1) "test string" set env(NAME2) "more" -} -constraints {exec} -body { +} -body { set env(XYZZY) "garbage" getenv -} -cleanup { - encoding system $sysenc +} -cleanup { cleanup1 } -result {NAME1=test string NAME2=more XYZZY=garbage} -set env(NAME1) "test string" -set env(NAME2) "new value" -set env(XYZZY) "garbage" -test env-3.1 {changing environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { + +test env-3.1 { + changing environment variables +} -constraints exec -setup setup2 -body { set result [getenv] unset env(NAME2) set result } -cleanup { - encoding system $sysenc + cleanup1 } -result {NAME1=test string NAME2=new value XYZZY=garbage} -unset -nocomplain env(NAME2) -test env-4.1 {unsetting environment variables: default} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { + +test env-4.1 { + unsetting environment variables +} -constraints exec -setup setup2 -body { + unset -nocomplain env(NAME2) getenv -} -cleanup { - encoding system $sysenc -} -result {NAME1=test string +} -cleanup cleanup1 -result {NAME1=test string XYZZY=garbage} -test env-4.2 {unsetting environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { - unset env(NAME1) - getenv -} -cleanup { - unset env(XYZZY) - encoding system $sysenc -} -result {XYZZY=garbage} -unset -nocomplain env(NAME1) env(XYZZY) -test env-4.3 {setting international environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { + +# env-4.2 is deleted + +test env-4.3 { + setting international environment variables +} -constraints exec -setup setup1 -body { set env(\ua7) \ub6 getenv -} -cleanup { - encoding system $sysenc -} -result {\u00a7=\u00b6} -test env-4.4 {changing international environment variables} -setup { - encoding system iso8859-1 -} -constraints {exec} -body { +} -cleanup cleanup1 -result {\u00a7=\u00b6} + + +test env-4.4 { + changing international environment variables +} -constraints exec -setup setup1 -body { set env(\ua7) \ua7 getenv -} -cleanup { - encoding system $sysenc -} -result {\u00a7=\u00a7} -test env-4.5 {unsetting international environment variables} -setup { - encoding system iso8859-1 +} -cleanup cleanup1 -result {\u00a7=\u00a7} + + +test env-4.5 { + unsetting international environment variables +} -constraints exec -setup { + setup1 set env(\ua7) \ua7 } -body { set env(\ub6) \ua7 unset env(\ua7) getenv -} -constraints {exec} -cleanup { - unset env(\ub6) - encoding system $sysenc -} -result {\u00b6=\u00a7} +} -cleanup cleanup1 -result {\u00b6=\u00a7} -test env-5.0 {corner cases - set a value, it should exist} -body { +test env-5.0 { + corner cases - set a value, it should exist +} -setup setup1 -body { set env(temp) a set env(temp) -} -cleanup { - unset env(temp) -} -result {a} -test env-5.1 {corner cases - remove one elem at a time} -setup { - set x [array get env] -} -body { +} -cleanup cleanup1 -result a + + +test env-5.1 { + corner cases - remove one elem at a time +} -setup setup1 -body { # When no environment variables exist, the env var will contain no # entries. The "array names" call synchs up the C-level environ array with # the Tcl level env array. Make sure an empty Tcl array is created. @@ -246,9 +288,9 @@ test env-5.1 {corner cases - remove one elem at a time} -setup { unset env($e) } array size env -} -cleanup { - array set env $x -} -result {0} +} -cleanup cleanup1 -result 0 + + test env-5.2 {corner cases - unset the env array} -setup { interp create i } -body { @@ -262,42 +304,54 @@ test env-5.2 {corner cases - unset the env array} -setup { } -cleanup { interp delete i } -result {0} + + test env-5.3 {corner cases: unset the env in master should unset child} -setup { + setup1 interp create i } -body { # Variables deleted in a master interp should be deleted in child interp # too. - i eval { set env(THIS_SHOULD_EXIST) a} + i eval {set env(THIS_SHOULD_EXIST) a} set result [set env(THIS_SHOULD_EXIST)] unset env(THIS_SHOULD_EXIST) lappend result [i eval {catch {set env(THIS_SHOULD_EXIST)}}] } -cleanup { + cleanup1 interp delete i } -result {a 1} + + test env-5.4 {corner cases - unset the env array} -setup { + setup1 interp create i } -body { # The info exists command should be in synch with the env array. # Know Bug: 1737 - i eval { set env(THIS_SHOULD_EXIST) a} + i eval {set env(THIS_SHOULD_EXIST) a} set result [info exists env(THIS_SHOULD_EXIST)] lappend result [set env(THIS_SHOULD_EXIST)] lappend result [info exists env(THIS_SHOULD_EXIST)] } -cleanup { + cleanup1 interp delete i } -result {1 a 1} -test env-5.5 {corner cases - cannot have null entries on Windows} -constraints win -body { + + +test env-5.5 { + corner cases - cannot have null entries on Windows +} -constraints win -body { set env() a catch {set env()} -} -result 1 +} -cleanup cleanup1 -result 1 -test env-6.1 {corner cases - add lots of env variables} -body { +test env-6.1 {corner cases - add lots of env variables} -setup setup1 -body { set size [array size env] for {set i 0} {$i < 100} {incr i} { set env(BOGUS$i) $i } expr {[array size env] - $size} -} -result 100 +} -cleanup cleanup1 -result 100 test env-7.1 {[219226]: whole env array should not be unset by read} -body { set n [array size env] @@ -310,16 +364,20 @@ test env-7.1 {[219226]: whole env array should not be unset by read} -body { return $n } -result 0 -test env-7.2 {[219226]: links to env elements should not be removed by read} -body { +test env-7.2 { + [219226]: links to env elements should not be removed by read +} -setup setup1 -body { apply {{} { set ::env(test7_2) ok upvar env(test7_2) elem set ::env(PATH) return $elem }} -} -result ok +} -cleanup cleanup1 -result ok -test env-7.3 {[9b4702]: testing existence of env(some_thing) should not destroy trace} -body { +test env-7.3 { + [9b4702]: testing existence of env(some_thing) should not destroy trace +} -setup setup1 -body { apply {{} { catch {unset ::env(test7_3)} proc foo args { @@ -330,16 +388,25 @@ test env-7.3 {[9b4702]: testing existence of env(some_thing) should not destroy set ::env(not_yet_existent) "Now I'm here"; return [info exists ::env(test7_3)] }} -} -result 1 +} -cleanup cleanup1 -result 1 -# Restore the environment variables at the end of the test. +test env-8.0 { + memory usage - valgrind does not report reachable memory +} -body { + set res [set env(__DUMMY__) {i'm with dummy}] + unset env(__DUMMY__) + return $res +} -result {i'm with dummy} + -foreach name [array names env] { - unset env($name) -} -array set env $env2 # cleanup +rename getenv {} +rename envrestore {} +rename envprep {} +rename encodingrestore {} +rename encodingswitch {} + removeFile $printenvScript ::tcltest::cleanupTests return diff --git a/tests/exec.test b/tests/exec.test index 3d1cd56..4fd8b8d 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -11,9 +11,16 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. +# There is no point in running Valgrind on cases where [exec] forks but then +# fails and the child process doesn't go through full cleanup. + package require tcltest 2 namespace import -force ::tcltest::* +loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] +package require tcltests + # All tests require the "exec" command. # Skip them if exec is not defined. testConstraint exec [llength [info commands exec]] @@ -325,11 +332,11 @@ test exec-8.2 {long input and output} {exec} { # Commands that return errors. -test exec-9.1 {commands returning errors} {exec} { +test exec-9.1 {commands returning errors} {exec notValgrind} { set x [catch {exec gorp456} msg] list $x [string tolower $msg] [string tolower $errorCode] } {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}} -test exec-9.2 {commands returning errors} {exec} { +test exec-9.2 {commands returning errors} {exec notValgrind} { string tolower [list [catch {exec [interpreter] echo foo | foo123} msg] $msg $errorCode] } {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}} test exec-9.3 {commands returning errors} -constraints {exec stdio} -body { @@ -339,7 +346,7 @@ test exec-9.4 {commands returning errors} -constraints {exec stdio} -body { exec [interpreter] $path(exit) 43 | [interpreter] $path(echo) "foo bar" } -returnCodes error -result {foo bar child process exited abnormally} -test exec-9.5 {commands returning errors} -constraints {exec stdio} -body { +test exec-9.5 {commands returning errors} -constraints {exec stdio notValgrind} -body { exec gorp456 | [interpreter] echo a b c } -returnCodes error -result {couldn't execute "gorp456": no such file or directory} test exec-9.6 {commands returning errors} -constraints {exec} -body { @@ -428,13 +435,13 @@ test exec-10.19 {errors in exec invocation} -constraints {exec} -body { exec cat >@ $f } -returnCodes error -result "channel \"$f\" wasn't opened for writing" close $f -test exec-10.20 {errors in exec invocation} -constraints {exec} -body { +test exec-10.20 {errors in exec invocation} -constraints {exec notValgrind} -body { exec ~non_existent_user/foo/bar } -returnCodes error -result {user "non_existent_user" doesn't exist} -test exec-10.21 {errors in exec invocation} -constraints {exec} -body { +test exec-10.21 {errors in exec invocation} -constraints {exec notValgrind} -body { exec [interpreter] true | ~xyzzy_bad_user/x | false } -returnCodes error -result {user "xyzzy_bad_user" doesn't exist} -test exec-10.22 {errors in exec invocation} -constraints exec -body { +test exec-10.22 {errors in exec invocation} -constraints {exec notValgrind} -body { exec echo test > ~non_existent_user/foo/bar } -returnCodes error -result {user "non_existent_user" doesn't exist} # Commands in background. @@ -510,7 +517,7 @@ test exec-13.1 {setting errorCode variable} {exec} { test exec-13.2 {setting errorCode variable} {exec} { list [catch {exec [interpreter] $path(cat) > a/b/c} msg] [string tolower $errorCode] } {1 {posix enoent {no such file or directory}}} -test exec-13.3 {setting errorCode variable} {exec} { +test exec-13.3 {setting errorCode variable} {exec notValgrind} { set x [catch {exec _weird_cmd_} msg] list $x [string tolower $msg] [lindex $errorCode 0] \ [string tolower [lrange $errorCode 2 end]] @@ -548,7 +555,7 @@ test exec-14.2 {-keepnewline switch} -constraints {exec} -body { test exec-14.3 {unknown switch} -constraints {exec} -body { exec -gorp } -returnCodes error -result {bad option "-gorp": must be -ignorestderr, -keepnewline, or --} -test exec-14.4 {-- switch} -constraints {exec} -body { +test exec-14.4 {-- switch} -constraints {exec notValgrind} -body { exec -- -gorp } -returnCodes error -result {couldn't execute "-gorp": no such file or directory} test exec-14.5 {-ignorestderr switch} {exec} { @@ -662,7 +669,7 @@ test exec-18.2 {exec cat deals with weird file names} -body { # Note that this test cannot be adapted to work on Windows; that platform has # no kernel support for an analog of O_APPEND. OTOH, that means we can assume # that there is a POSIX shell... -test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix} -setup { +test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix notValgrind} -setup { set tmpfile [makeFile {0} tmpfile.exec-19.1] } -body { # Note that we have to allow for the current contents of the temporary @@ -675,7 +682,7 @@ test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix} -setup { {for a in a b c; do sleep 1; echo $a; done} >>$tmpfile & exec /bin/sh -c \ {for a in d e f; do sleep 1; echo $a >&2; done} 2>>$tmpfile & - # The above four shell invokations take about 3 seconds to finish, so allow + # The above four shell invocations take about 3 seconds to finish, so allow # 5s (in case the machine is busy) after 5000 # Check that no bytes have got lost through mixups with overlapping diff --git a/tests/execute.test b/tests/execute.test index 6c277f8..3b62bc9 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -34,7 +34,7 @@ testConstraint testobj [expr { && [llength [info commands teststringobj]] }] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] testConstraint testexprlongobj [llength [info commands testexprlongobj]] # Tests for the omnibus TclExecuteByteCode function: @@ -805,9 +805,9 @@ test execute-7.7 {Wide int handling in INST_EQ and [incr]} { set y [expr {$x+1}] expr {double($x) == double($y)} } 1 -test execute-7.8 {Wide int conversions can change sign} longIs32bit { - set x 0x80000000 - expr {int($x) < wide($x)} +test execute-7.8 {Wide int conversions can change sign} { + set x 0x8000000000000000 + expr {wide($x) < 0} } 1 test execute-7.9 {Wide int handling in INST_MOD} { expr {(wide(1)<<60) % ((wide(47)<<45)-1)} @@ -887,12 +887,12 @@ test execute-7.31 {Wide int handling in abs()} { set y 0x123456871234568 concat [expr {abs($x)}] [expr {abs($y)}] } {730503879441204585 81985533099853160} -test execute-7.32 {Wide int handling} longIs32bit { +test execute-7.32 {Wide int handling} { expr {int(1024 * 1024 * 1024 * 1024)} -} 0 -test execute-7.33 {Wide int handling} longIs32bit { +} 1099511627776 +test execute-7.33 {Wide int handling} { expr {int(0x1 * 1024 * 1024 * 1024 * 1024)} -} 0 +} 1099511627776 test execute-7.34 {Wide int handling} { expr {wide(0x1) * 1024 * 1024 * 1024 * 1024} } 1099511627776 diff --git a/tests/expr-old.test b/tests/expr-old.test index a73b77a..003ee00 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -22,7 +22,8 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testexprlong [llength [info commands testexprlong]] testConstraint testexprdouble [llength [info commands testexprdouble]] testConstraint testexprstring [llength [info commands testexprstring]] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] # Big test for correct ordering of data in [expr] @@ -813,10 +814,10 @@ test expr-old-32.32 {math functions in expressions} { } {-1} test expr-old-32.33 {math functions in expressions} { expr int(1e60) -} 0 +} 999999999999999949387135297074018866963645011013410073083904 test expr-old-32.34 {math functions in expressions} { expr int(-1e60) -} 0 +} -999999999999999949387135297074018866963645011013410073083904 test expr-old-32.35 {math functions in expressions} { expr round(1.49) } {1} @@ -1035,8 +1036,8 @@ test expr-old-37.8 {Tcl_ExprLong handles overflows} testexprlong { testexprlong -0x80000000 } {This is a result: -2147483648} test expr-old-37.9 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { - testexprlong -0xffffffff -} {This is a result: 1} + testexprlong -0x7fffffff +} {This is a result: -2147483647} test expr-old-37.10 {Tcl_ExprLong handles overflows} \ -constraints {testexprlong longIs32bit} \ -match glob \ @@ -1060,9 +1061,13 @@ test expr-old-37.13 {Tcl_ExprLong handles overflows} \ test expr-old-37.14 {Tcl_ExprLong handles overflows} testexprlong { testexprlong -2147483648. } {This is a result: -2147483648} -test expr-old-37.15 {Tcl_ExprLong handles overflows} {testexprlong longIs32bit} { - testexprlong -4294967295. -} {This is a result: 1} +test expr-old-37.15 {Tcl_ExprLong handles overflows} \ + -constraints {testexprlong longIs32bit} \ + -match glob \ + -body { + list [catch {testexprlong -2147483649.} result] $result + } \ + -result {1 {integer value too large to represent*}} test expr-old-37.16 {Tcl_ExprLong handles overflows} \ -constraints {testexprlong longIs32bit} \ -match glob \ diff --git a/tests/expr.test b/tests/expr.test index de6eb4a..7136afc 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -21,10 +21,9 @@ catch [list package require -exact Tcltest [info patchlevel]] # Determine if "long int" type is a 32 bit number and if the wide # type is a 64 bit number on this machine. -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] -testConstraint wideIs64bit \ - [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] +testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] # Big test for correct ordering of data in [expr] @@ -417,12 +416,9 @@ test expr-9.1 {CompileRelationalExpr: just shift expr} {expr 3<<2} 12 test expr-9.2 {CompileRelationalExpr: just shift expr} {expr 0xff>>2} 63 test expr-9.3 {CompileRelationalExpr: just shift expr} {expr -1>>2} -1 test expr-9.4 {CompileRelationalExpr: just shift expr} {expr {1<<3}} 8 -test expr-9.5a {CompileRelationalExpr: shift expr producing LONG_MIN} longIs64bit { +test expr-9.5 {CompileRelationalExpr: shift expr producing LONG_MIN} { expr {int(1<<63)} -} -9223372036854775808 -test expr-9.5b {CompileRelationalExpr: shift expr producing LONG_MIN} longIs32bit { - expr {int(1<<31)} -} -2147483648 +} 9223372036854775808 test expr-9.6 {CompileRelationalExpr: error in shift expr} -body { expr x>>3 } -returnCodes error -match glob -result * @@ -1405,8 +1401,8 @@ test expr-24.1 {expr edge cases; shifting} {expr int(5)>>32} 0 test expr-24.2 {expr edge cases; shifting} {expr int(5)>>63} 0 test expr-24.3 {expr edge cases; shifting} {expr wide(5)>>32} 0 test expr-24.4 {expr edge cases; shifting} {expr wide(5)>>63} 0 -test expr-24.5 {expr edge cases; shifting} longIs32bit {expr int(5<<32)} 0 -test expr-24.6 {expr edge cases; shifting} longIs32bit {expr int(5<<63)} 0 +test expr-24.5 {expr edge cases; shifting} {expr int(5<<32)} 21474836480 +test expr-24.6 {expr edge cases; shifting} {expr int(5<<63)} 46116860184273879040 test expr-24.7 {expr edge cases; shifting} {expr wide(5)<<32} 21474836480 test expr-24.8 {expr edge cases; shifting} {expr wide(10<<63)} 0 test expr-24.9 {expr edge cases; shifting} {expr 5>>32} 0 @@ -5809,7 +5805,7 @@ test expr-32.9 {bignum regression} { expr {0%-(1+(1<<63))} } 0 -test expr-33.1 {parse largest long value} longIs32bit { +test expr-33.1 {parse largest long value} { set max_long_str 2147483647 set max_long_hex "0x7FFFFFFF " @@ -5823,7 +5819,7 @@ test expr-33.1 {parse largest long value} longIs32bit { [expr {$max_long + 0}] \ [expr {2147483647 + 0}] \ [expr {$max_long == $max_long_hex}] \ - [expr {int(2147483647 + 1) < 0}] \ + [expr {int(2147483647 + 1) > 0}] \ } {2147483647 2147483647 2147483647 2147483647 1 1} test expr-33.2 {parse smallest long value} longIs32bit { @@ -5843,7 +5839,7 @@ test expr-33.2 {parse smallest long value} longIs32bit { [expr {$min_long + 0}] \ [expr {-2147483648 + 0}] \ [expr {$min_long == $min_long_hex}] \ - [expr {int(-2147483648 - 1) == 0x7FFFFFFF}] \ + [expr {int(-2147483648 - 1) == -0x80000001}] \ } {-2147483648 -2147483648 -2147483648 -2147483648 1 1} test expr-33.3 {parse largest wide value} wideIs64bit { @@ -5923,17 +5919,17 @@ test expr-34.11 {expr edge cases} { test expr-34.12 {expr edge cases} { expr {$min % -2} } {0} -test expr-34.13 {expr edge cases} longIs32bit { +test expr-34.13 {expr edge cases} { expr {int($min / -1)} -} {-2147483648} +} {2147483648} test expr-34.14 {expr edge cases} { expr {$min % -1} } {0} -test expr-34.15 {expr edge cases} longIs32bit { - expr {int($min * -1)} +test expr-34.15 {expr edge cases} { + expr {-int($min * -1)} } $min -test expr-34.16 {expr edge cases} longIs32bit { - expr {int(-$min)} +test expr-34.16 {expr edge cases} { + expr {-int(-$min)} } $min test expr-34.17 {expr edge cases} { expr {$min / 1} @@ -6720,8 +6716,8 @@ test expr-39.8 {Tcl_ExprLongObj handles overflows} testexprlongobj { testexprlongobj -0x80000000 } {This is a result: -2147483648} test expr-39.9 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { - testexprlongobj -0xffffffff -} {This is a result: 1} + testexprlongobj -0x7fffffff +} {This is a result: -2147483647} test expr-39.10 {Tcl_ExprLongObj handles overflows} \ -constraints {testexprlongobj longIs32bit} \ -match glob \ @@ -6746,8 +6742,8 @@ test expr-39.14 {Tcl_ExprLongObj handles overflows} testexprlongobj { testexprlongobj -2147483648. } {This is a result: -2147483648} test expr-39.15 {Tcl_ExprLongObj handles overflows} {testexprlongobj longIs32bit} { - testexprlongobj -4294967295. -} {This is a result: 1} + testexprlongobj -2147483648. +} {This is a result: -2147483648} test expr-39.16 {Tcl_ExprLongObj handles overflows} \ -constraints {testexprlongobj longIs32bit} \ -match glob \ @@ -7157,6 +7153,15 @@ test expr-51.1 {test round-to-even on input} { expr 6.9294956446009195e15 } 6929495644600920.0 +test expr-52.1 { + comparison with empty string does not generate string representation +} { + set a [list one two three] + list [expr {$a eq {}}] [expr {$a < {}}] [expr {$a > {}}] [ + string match {*no string representation*} [ + ::tcl::unsupported::representation $a]] +} {0 0 1 1} + # cleanup diff --git a/tests/fCmd.test b/tests/fCmd.test index 709bfb4..87134d2 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -65,8 +65,7 @@ if {[testConstraint unix]} { # Also used in winFCmd... if {[testConstraint win]} { - set major [string index $tcl_platform(osVersion) 0] - if {$major > 5} { + if {$::tcl_platform(osVersion) >= 5.0} { testConstraint winVista 1 } else { testConstraint winXP 1 @@ -76,7 +75,7 @@ if {[testConstraint win]} { testConstraint darwin9 [expr { [testConstraint unix] && $tcl_platform(os) eq "Darwin" - && [package vsatisfies 1.$tcl_platform(osVersion) 1.9] + && [package vsatisfies 1.$::tcl_platform(osVersion) 1.9] }] testConstraint notDarwin9 [expr {![testConstraint darwin9]}] @@ -2307,7 +2306,7 @@ test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} -setup { if { [testConstraint win] && - ([string index $tcl_platform(osVersion) 0] < 5 + ($::tcl_platform(osVersion) < 5.0 || [lindex [file system [temporaryDirectory]] 1] ne "NTFS") } then { testConstraint linkDirectory 0 diff --git a/tests/fileName.test b/tests/fileName.test index 7f983a7..7b51da1 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -23,7 +23,7 @@ testConstraint testtranslatefilename [llength [info commands testtranslatefilena testConstraint linkDirectory 1 testConstraint symbolicLinkFile 1 if {[testConstraint win]} { - if {[string index $tcl_platform(osVersion) 0] < 5 \ + if {$::tcl_platform(osVersion) < 5.0 \ || [lindex [file system [temporaryDirectory]] 1] ne "NTFS"} { testConstraint linkDirectory 0 } diff --git a/tests/format.test b/tests/format.test index ed8676a..1bf46a1 100644 --- a/tests/format.test +++ b/tests/format.test @@ -16,11 +16,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } # %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)}] +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] +testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}] test format-1.1 {integer formatting} { @@ -547,7 +545,7 @@ for {set i 290} {$i < 400} {incr i} { append b "x" } -test format-17.1 {testing %d with wide} {wideIs64bit wideBiggerThanInt} { +test format-17.1 {testing %d with wide} {longIs32bit wideIs64bit} { format %d 7810179016327718216 } 1819043144 test format-17.2 {testing %ld with wide} {wideIs64bit} { @@ -580,7 +578,7 @@ test format-18.1 {do not demote existing numeric values} { format %08x $b lappend result [expr {$a == $b}] } {1 1 1 1} -test format-18.2 {do not demote existing numeric values} {wideBiggerThanInt} { +test format-18.2 {do not demote existing numeric values} {longIs32bit wideIs64bit} { set a [expr {0xaaaaaaaaaa + 1}] set b 0xaaaaaaaaab list [format %08x $a] [expr {$a == $b}] @@ -597,6 +595,20 @@ test format-19.3 {Bug 2830354} { string length [format %340f 0] } 340 +test format-19.4.1 {Bug d498578df4: width overflow should cause limit exceeded} \ +-constraints {longIs32bit} -body { + # in case of overflow into negative, it produces width -2 (and limit exceeded), + # in case of width will be unsigned, it will be outside limit (2GB for 32bit)... + # and it don't throw an error in case the bug is not fixed (and probably no segfault). + format %[expr {0xffffffff - 1}]g 0 +} -returnCodes error -result "max size for a Tcl value exceeded" + +test format-19.4.2 {Bug d498578df4: width overflow should cause limit exceeded} -body { + # limit should exceeds in any case, + # and it don't throw an error in case the bug is not fixed (and probably no segfault). + format %[expr {0xffffffffffffffff - 1}]g 0 +} -returnCodes error -result "max size for a Tcl value exceeded" + # Note that this test may fail in future versions test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body { set x [dict create a b c d] diff --git a/tests/get.test b/tests/get.test index d6a7206..e35b2cc 100644 --- a/tests/get.test +++ b/tests/get.test @@ -20,8 +20,8 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testgetint [llength [info commands testgetint]] testConstraint testdoubleobj [llength [info commands testdoubleobj]] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] test get-1.1 {Tcl_GetInt procedure} testgetint { testgetint 44 { 22} @@ -45,14 +45,14 @@ test get-1.7 {Tcl_GetInt procedure} {testgetint longIs64bit} { list [catch {testgetint 44 18446744073709551616} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} test get-1.8 {Tcl_GetInt procedure} {testgetint longIs64bit} { - list [catch {testgetint 18446744073709551614} msg] $msg -} {0 -2} + testgetint 18446744073709551614 +} {-2} test get-1.9 {Tcl_GetInt procedure} {testgetint longIs64bit} { - list [catch {testgetint +18446744073709551614} msg] $msg -} {0 -2} + testgetint +18446744073709551614 +} {-2} test get-1.10 {Tcl_GetInt procedure} {testgetint longIs64bit} { - list [catch {testgetint -18446744073709551614} msg] $msg -} {0 2} + list [catch {testgetint -18446744073709551614} msg] $msg $errorCode +} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} test get-1.11 {Tcl_GetInt procedure} {testgetint longIs32bit} { list [catch {testgetint 44 4294967296} msg] $msg $errorCode } {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}} @@ -64,7 +64,7 @@ test get-1.13 {Tcl_GetInt procedure} {testgetint longIs32bit} { } {0 -2} test get-1.14 {Tcl_GetInt procedure} {testgetint longIs32bit} { list [catch {testgetint -4294967294} msg] $msg -} {0 2} +} {1 {integer value too large to represent}} test get-2.1 {Tcl_GetInt procedure} { format %g 1.23 diff --git a/tests/http.test b/tests/http.test index e165804..b6a7251 100644 --- a/tests/http.test +++ b/tests/http.test @@ -82,7 +82,7 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { test http-1.1 {http::config} { http::config -useragent UserAgent http::config -} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "UserAgent"] +} [list -accept */* -pipeline 1 -postfresh 0 -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -repost 0 -urlencoding utf-8 -useragent UserAgent -zip 1] test http-1.2 {http::config} { http::config -proxyfilter } http::ProxyRequired @@ -97,10 +97,10 @@ test http-1.4 {http::config} { set x [http::config] http::config {*}$savedconf set x -} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}} +} {-accept */* -pipeline 1 -postfresh 0 -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -repost 0 -urlencoding iso8859-1 -useragent {Tcl Test Suite} -zip 1} test http-1.5 {http::config} -returnCodes error -body { http::config -proxyhost {} -junk 8080 -} -result {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent} +} -result {Unknown option -junk, must be: -accept, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip} test http-1.6 {http::config} -setup { set oldenc [http::config -urlencoding] } -body { diff --git a/tests/http11.test b/tests/http11.test index c9ded0b..1e30802 100644 --- a/tests/http11.test +++ b/tests/http11.test @@ -515,10 +515,7 @@ proc handler {var sock token} { set chunk [read $sock] append data $chunk #::http::Log "handler read [string length $chunk] ([chan configure $sock -buffersize])" - if {[eof $sock]} { - #::http::Log "handler eof $sock" - chan event $sock readable {} - } + return [string length $chunk] } test http11-3.0 "-handler,close,identity" -setup { @@ -666,6 +663,13 @@ test http11-4.3 "normal post request, check channel query length" -setup { # ------------------------------------------------------------------------- +# Eliminate valgrind "still reachable" reports on outstanding "Detached" +# structures in the detached list which stem from PipeClose2Proc not waiting +# around for background processes to complete, meaning that previous calls to +# Tcl_ReapDetachedProcs might not have had a chance to reap all processes. +after 10 +exec [info nameofexecutable] << {} + foreach p {create_httpd httpd_read halt_httpd meta check_crc} { if {[llength [info proc $p]]} {rename $p {}} } diff --git a/tests/httpPipeline.test b/tests/httpPipeline.test new file mode 100644 index 0000000..8de79b9 --- /dev/null +++ b/tests/httpPipeline.test @@ -0,0 +1,866 @@ +# httpPipeline.test +# +# Test HTTP/1.1 concurrent requests including +# queueing, pipelining and retries. +# +# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net> +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require tcltest 2 +namespace import -force ::tcltest::* + +package require http 2.8 + +set sourcedir [file normalize [file dirname [info script]]] +source [file join $sourcedir httpTest.tcl] +source [file join $sourcedir httpTestScript.tcl] + +# ------------------------------------------------------------------------------ +# (1) Define the test scripts that will be used to generate logs for analysis - +# and also define the "correct" results. +# ------------------------------------------------------------------------------ + +proc ReturnTestScriptAndResult {ca cb delay te} { + + switch -- $ca { + 1 {set start { + START + KEEPALIVE 0 + PIPELINE 0 + }} + + 2 {set start { + START + KEEPALIVE 0 + PIPELINE 1 + }} + + 3 {set start { + START + KEEPALIVE 1 + PIPELINE 0 + }} + + 4 {set start { + START + KEEPALIVE 1 + PIPELINE 1 + }} + + default { + return -code error {no matching script} + } + } + + set middle " + [list DELAY $delay] + " + + switch -- $cb { + 1 {set end { + GET a + GET b + GET c + GET a + STOP + } + set resShort {1 ? ? ?} + set resLong {1 2 3 4} + } + + 2 {set end { + GET a + HEAD b + GET c + HEAD a + HEAD c + STOP + } + set resShort {1 ? ? ? ?} + set resLong {1 2 3 4 5} + } + + 3 {set end { + HEAD a + GET b + HEAD c + HEAD b + GET a + GET b + STOP + } + set resShort {1 ? ? ? ? ?} + set resLong {1 2 3 4 5 6} + } + + 4 {set end { + GET a + GET b + GET c + GET a + POST b address=home code=brief paid=yes + GET c + GET a + GET b + GET c + STOP + } + set resShort {1 ? ? ? 5 ? ? ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 5 {set end { + POST a address=home code=brief paid=yes + POST b address=home code=brief paid=yes + POST c address=home code=brief paid=yes + POST a address=home code=brief paid=yes + POST b address=home code=brief paid=yes + POST c address=home code=brief paid=yes + POST a address=home code=brief paid=yes + POST b address=home code=brief paid=yes + POST c address=home code=brief paid=yes + STOP + } + set resShort {1 2 3 4 5 6 7 8 9} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 6 {set end { + POST a address=home code=brief paid=yes + GET b address=home code=brief paid=yes + POST c address=home code=brief paid=yes + GET a address=home code=brief paid=yes + GET b address=home code=brief paid=yes + POST c address=home code=brief paid=yes + POST a address=home code=brief paid=yes + HEAD b address=home code=brief paid=yes + GET c address=home code=brief paid=yes + STOP + } + set resShort {1 ? 3 ? ? 6 7 ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 7 {set end { + GET b address=home code=brief paid=yes + POST a address=home code=brief paid=yes + GET a address=home code=brief paid=yes + POST c address=home code=brief paid=yes + GET b address=home code=brief paid=yes + HEAD b address=home code=brief paid=yes + POST c address=home code=brief paid=yes + POST a address=home code=brief paid=yes + GET c address=home code=brief paid=yes + STOP + } + set resShort {1 2 ? 4 ? ? 7 8 ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 8 {set end { + # Telling the server to close the connection. + GET a + GET b close=y + GET c + GET a + GET b + GET c + GET a + GET b + GET c + STOP + } + set resShort {1 ? 3 ? ? ? ? ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 9 {set end { + # Telling the server to close the connection. + GET a + POST b close=y address=home code=brief paid=yes + GET c + GET a + GET b + GET c + GET a + GET b + GET c + STOP + } + set resShort {1 2 3 ? ? ? ? ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 10 {set end { + # Telling the server to close the connection. + GET a + GET b close=y + POST c address=home code=brief paid=yes + GET a + GET b + GET c + GET a + GET b + GET c + STOP + } + set resShort {1 ? 3 ? ? ? ? ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 11 {set end { + # Telling the server to close the connection twice. + GET a + GET b close=y + GET c + GET a + GET b close=y + GET c + GET a + GET b + GET c + STOP + } + set resShort {1 ? 3 ? ? 6 ? ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 12 {set end { + # Telling the server to delay before sending the response. + GET a + GET b delay=1 + GET c + GET a + GET b + STOP + } + set resShort {1 ? ? ? ?} + set resLong {1 2 3 4 5} + } + + 13 {set end { + # Making the server close the connection (time out). + GET a + WAIT 2000 + GET b + GET c + GET a + GET b + STOP + } + set resShort {1 2 ? ? ?} + set resLong {1 2 3 4 5} + } + + 14 {set end { + # Making the server close the connection (time out) twice. + GET a + WAIT 2000 + GET b + GET c + GET a + WAIT 2000 + GET b + GET c + GET a + GET b + GET c + STOP + } + set resShort {1 2 ? ? 5 ? ? ? ?} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 15 {set end { + POST a address=home code=brief paid=yes + POST b address=home code=brief paid=yes close=y delay=1 + POST c address=home code=brief paid=yes delay=1 + POST a address=home code=brief paid=yes close=y + WAIT 2000 + POST b address=home code=brief paid=yes delay=1 + POST c address=home code=brief paid=yes close=y + POST a address=home code=brief paid=yes + POST b address=home code=brief paid=yes close=y + POST c address=home code=brief paid=yes + STOP + } + set resShort {1 2 3 4 5 6 7 8 9} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 16 {set end { + POST a address=home code=brief paid=yes + GET b address=home code=brief paid=yes + POST c address=home code=brief paid=yes close=y + GET a address=home code=brief paid=yes + GET b address=home code=brief paid=yes close=y + POST c address=home code=brief paid=yes + WAIT 2000 + POST a address=home code=brief paid=yes + HEAD b address=home code=brief paid=yes close=y + GET c address=home code=brief paid=yes + STOP + } + set resShort {1 ? 3 4 ? 6 7 ? 9} + set resLong {1 2 3 4 5 6 7 8 9} + } + + 17 {set end { + GET b address=home code=brief paid=yes + POST a address=home code=brief paid=yes + GET a address=home code=brief paid=yes + POST c address=home code=brief paid=yes close=y + GET b address=home code=brief paid=yes + HEAD b address=home code=brief paid=yes close=y + POST c address=home code=brief paid=yes + WAIT 2000 + POST a address=home code=brief paid=yes + WAIT 2000 + GET c address=home code=brief paid=yes + STOP + } + set resShort {1 2 3 4 5 ? 7 8 9} + set resLong {1 2 3 4 5 6 7 8 9} + } + + + 18 {set end { + REPOST 0 + GET a + WAIT 2000 + POST b address=home code=brief paid=yes + GET c + GET a + STOP + } + set resShort {1 2 ? ?} + set resLong {1 2 3 4} + # resShort is overwritten below for the case ($te == 1). + } + + + 19 {set end { + REPOST 0 + GET a + WAIT 2000 + GET b address=home code=brief paid=yes + GET c + GET a + STOP + } + set resShort {1 2 ? ?} + set resLong {1 2 3 4} + } + + + 20 {set end { + POSTFRESH 1 + GET a + WAIT 2000 + POST b address=home code=brief paid=yes + GET c + GET a + STOP + } + set resShort {1 3 ?} + set resLong {1 3 4} + } + + + 21 {set end { + POSTFRESH 1 + GET a + WAIT 2000 + GET b address=home code=brief paid=yes + GET c + GET a + STOP + } + set resShort {1 2 ? ?} + set resLong {1 2 3 4} + } + + 22 {set end { + GET a + WAIT 2000 + KEEPALIVE 0 + POST b address=home code=brief paid=yes + KEEPALIVE 1 + GET c + GET a + STOP + } + set resShort {1 3 ?} + set resLong {1 3 4} + } + + + 23 {set end { + GET a + WAIT 2000 + KEEPALIVE 0 + GET b address=home code=brief paid=yes + KEEPALIVE 1 + GET c + GET a + STOP + } + set resShort {1 3 ?} + set resLong {1 3 4} + } + + 24 {set end { + GET a + KEEPALIVE 0 + POST b address=home code=brief paid=yes + KEEPALIVE 1 + GET c + GET a + STOP + } + set resShort {1 ? ?} + set resLong {1 3 4} + } + + + 25 {set end { + GET a + KEEPALIVE 0 + GET b address=home code=brief paid=yes + KEEPALIVE 1 + GET c + GET a + STOP + } + set resShort {1 ? ?} + set resLong {1 3 4} + } + + default { + return -code error {no matching script} + } + } + + + if {$ca < 3} { + # Not Keep-Alive. + set result "Passed all sanity checks." + + } elseif {$ca == 3} { + # Keep-Alive, not pipelined. + set result {} + append result "Passed all sanity checks.\n" + append result "Have overlaps including response body:\n" + + } else { + # Keep-Alive, pipelined: ($ca == 4) + set result {} + append result "Passed all sanity checks.\n" + append result "Overlap-free without response body:\n" + append result "$resShort" + } + + # - The special case of test *.18*-testEof needs test results to be + # individually written. + # - These test -repost 0 when there is a POST to apply it to, and the server + # timeout has not been detected. + if {($cb == 18) && ($te == 1)} { + if {$ca < 3} { + # Not Keep-Alive. + set result "Passed all sanity checks." + + } elseif {$ca == 3 && $delay == 0} { + # Keep-Alive, not pipelined. + set result [MakeMessage { + |Problems with sanity checks: + |Wrong sequence for token ::http::2 - {A B C D X X X} + |- and error(s) X + |Wrong sequence for token ::http::3 - {A X X} + |- and error(s) X + |Wrong sequence for token ::http::4 - {A X X X} + |- and error(s) X + | + |Have overlaps including response body: + | + }] + + } elseif {$ca == 3} { + # Keep-Alive, not pipelined. + set result [MakeMessage { + |Problems with sanity checks: + |Wrong sequence for token ::http::2 - {A B C D X X X} + |- and error(s) X + | + |Have overlaps including response body: + | + }] + + } elseif {$delay == 0} { + # Keep-Alive, pipelined: ($ca == 4) + set result [MakeMessage { + |Problems with sanity checks: + |Wrong sequence for token ::http::2 - {A B C D X X X} + |- and error(s) X + |Wrong sequence for token ::http::3 - {A X X} + |- and error(s) X + |Wrong sequence for token ::http::4 - {A X X X} + |- and error(s) X + | + |Overlap-free without response body: + | + }] + + } else { + set result [MakeMessage { + |Problems with sanity checks: + |Wrong sequence for token ::http::2 - {A B C D X X X} + |- and error(s) X + | + |Overlap-free without response body: + | + }] + + } + } + + return [list "$start$middle$end" $result] +} + +# ------------------------------------------------------------------------------ +# Proc MakeMessage +# ------------------------------------------------------------------------------ +# WHD's one-line command to generate multi-line strings from readable code. +# +# Example: +# set blurb [MakeMessage { +# |This command allows multi-line strings to be created with readable +# |code, and without breaking the rules for indentation. +# | +# |The command shifts the entire block of text to the left, omitting +# |the pipe character and the spaces to its left. +# }] +# ------------------------------------------------------------------------------ + +proc MakeMessage {in} { + regsub -all -line {^\s*\|} [string trim $in] {} + # N.B. Implicit Return. +} + + +proc ReturnTestScript {ca cb delay te} { + lassign [ReturnTestScriptAndResult $ca $cb $delay $te] script result + return $script +} + +proc ReturnTestResult {ca cb delay te} { + lassign [ReturnTestScriptAndResult $ca $cb $delay $te] script result + return $result +} + + +# ------------------------------------------------------------------------------ +# (2) Command to run a test script and use httpTest to analyse the logs. +# ------------------------------------------------------------------------------ + +namespace import httpTestScript::runHttpTestScript +namespace import httpTestScript::cleanupHttpTestScript +namespace import httpTest::cleanupHttpTest +namespace import httpTest::logAnalyse +namespace import httpTest::setHttpTestOptions + +proc RunTest {header footer delay te} { + set num [runHttpTestScript [ReturnTestScript $header $footer $delay $te]] + set skipOverlaps 0 + set notPiped {} + set notIncluded {} + + # -------------------------------------------------------------------------- + # Custom code for specific tests + # -------------------------------------------------------------------------- + if {$header < 3} { + set skipOverlaps 1 + for {set i 1} {$i <= $num} {incr i} { + lappend notPiped $i + } + } elseif {$header > 2 && $footer == 18 && $te == 1} { + set skipOverlaps 1 + if {$delay == 0} { + # Transaction 1 is conventional. + # Check that transactions 2,3,4 are cancelled. + set notPiped {1} + set notIncluded $notPiped + } else { + # Transaction 1 is conventional. + # Check that transaction 2 is cancelled. + # The timing of transactions 3 and 4 is uncertain. + set notPiped {1 3 4} + set notIncluded $notPiped + } + } elseif {$footer in {20 22 23 24 25}} { + # Transaction 2 uses its own socket. + set notPiped 2 + set notIncluded $notPiped + } else { + } + # -------------------------------------------------------------------------- + # End of custom code for specific tests + # -------------------------------------------------------------------------- + + + set Results [logAnalyse $num $skipOverlaps $notIncluded $notPiped] + lassign $Results msg cleanE cleanF dirtyE dirtyF + if {$msg eq {}} { + set msg "Passed all sanity checks." + } else { + set msg "Problems with sanity checks:\n$msg" + } + + if 0 { + puts $msg + puts "Overlap-free including response body:\n$cleanF" + puts "Have overlaps including response body:\n$dirtyF" + puts "Overlap-free without response body:\n$cleanE" + puts "Have overlaps without response body:\n$dirtyE" + } + + if {$header < 3} { + # No ordering, just check that transactions all finish + set result $msg + } elseif {$header == 3} { + # Not pipelined - check overlaps with response body. + set result "$msg\nHave overlaps including response body:\n$dirtyF" + } else { + # Pipelined - check overlaps without response body. Check that the + # first request, the first requests after replay, and POSTs are clean. + set result "$msg\nOverlap-free without response body:\n$cleanE" + } + set ::nTokens $num + return $result +} + + +# ------------------------------------------------------------------------------ +# (3) VERBOSITY CONTROL +# ------------------------------------------------------------------------------ +# If tests fail, run an individual test with -verbose 1 or 2 for diagnosis. +# If still obscure, uncomment #Log and ##Log lines in the http package. +# ------------------------------------------------------------------------------ + +setHttpTestOptions -verbose 0 + +# ------------------------------------------------------------------------------ +# (4) Define the base URLs used for testing. Each must have a query string. +# ------------------------------------------------------------------------------ +# - A HTTP/1.1 server is required. It should be configured to provide +# persistent connections when requested to do so, and to close these +# connections if they are idle for one second. +# - The resource must be served with status 200 in response to a valid GET or +# POST. +# - The value of "page" is always specified in the query-string. Different +# resources for the three values of "page" allow testing of both chunked and +# unchunked transfer encoding. +# - The variables "close" and "delay" may be specified in the query-string (for +# a GET) or the request body (for a POST). +# - "delay" is a numerical value in seconds, and causes the server to delay +# the response, including headers. +# - "close", if it has the value "y", instructs the server to close the +# connection ater the current request. +# - Any other variables should be ignored. +# ------------------------------------------------------------------------------ + +namespace eval ::httpTestScript { + variable URL + array set URL { + a http://test-tcl-http.kerlin.org/index.html?page=privacy + b http://test-tcl-http.kerlin.org/index.html?page=conditions + c http://test-tcl-http.kerlin.org/index.html?page=welcome + } +} + + +# ------------------------------------------------------------------------------ +# (5) Define the tests +# ------------------------------------------------------------------------------ +# Constraints: +# - serverNeeded - the URLs defined at (4) must be available, and must have the +# properties specified there. +# - duplicate - the value of -pipeline does not matter if -keepalive 0 +# - timeout1s - tests that work correctly only if the server closes +# persistent connections after one second. +# +# Server timeout of persistent connections should be 1s. Delays of 2s are +# intended to cause timeout. +# Servers are usually configured to use a longer timeout: this will cause the +# tests to fail. The "2000" could be replaced with a larger number, but the +# tests will then be inconveniently slow. +# ------------------------------------------------------------------------------ + +#testConstraint serverNeeded 1 +#testConstraint timeout1s 1 +#testConstraint duplicate 1 + +# ------------------------------------------------------------------------------ +# Proc SetTestEof - to edit the command ::http::KeepSocket +# ------------------------------------------------------------------------------ +# The usual line in command ::http::KeepSocket is " set TEST_EOF 0". +# Whether the value set in the file is 0 or 1, change it here to the value +# specified by the argument. +# +# It is worth doing all tests for both values of the argument. +# +# test 0 - ::http::KeepSocket is unchanged, detects server eof where possible +# and closes the connection. +# test 1 - ::http::KeepSocket is edited, does not detect server eof, so the +# reaction to finding server eof can be tested without the difficulty +# of testing in the few milliseconds of an asynchronous close event. +# ------------------------------------------------------------------------------ + +proc SetTestEof {test} { + set body [info body ::http::KeepSocket] + set subs " set TEST_EOF $test" + set count [regsub -line -all -- {^\s*set TEST_EOF .*$} $body $subs newBody] + if {$count != 1} { + return -code error {proc ::http::KeepSocket has unexpected form} + } + proc ::http::KeepSocket {token} $newBody + return +} + +for {set header 1} {$header <= 4} {incr header} { + if {$header == 4} { + setHttpTestOptions -dotted 1 + set match glob + } else { + setHttpTestOptions -dotted 0 + set match exact + } + + if {$header == 2} { + set cons0 {serverNeeded duplicate} + } else { + set cons0 serverNeeded + } + + for {set footer 1} {$footer <= 25} {incr footer} { + foreach {delay label} { + 0 a + 1 b + 2 c + 3 d + 5 e + 8 f + 12 g + 100 h + 500 i + 2000 j + } { + foreach te {0 1} { + if {$te} { + set tag testEof + } else { + set tag normal + } + set suffix {} + set cons $cons0 + + # ------------------------------------------------------------------ + # Custom code for individual tests + # ------------------------------------------------------------------ + if {$footer in {18}} { + # Custom code: + if {($label eq "j") && ($te == 1)} { + continue + } + if {$te == 1} { + # The test (of REPOST 0) is useful if tag is "testEof" + # (server timeout without client reaction). The same test + # has a different result if tag is "normal". + + set suffix " - extra test for -repost 0 - ::http::2 must be" + append suffix " cancelled" + if {($delay == 0)} { + append suffix ", along with ::http::3 ::http::4 if" + append suffix " the test creates these before ::http::2" + append suffix " is cancelled" + } + } else { + } + } elseif {$footer in {19}} { + set suffix " - extra test for -repost 0" + } elseif {$footer in {20 21}} { + set suffix " - extra test for -postfresh 1" + if {($footer == 20)} { + append suffix " - ::http::2 uses a separate socket" + append suffix ", other requests use a persistent connection" + } + } elseif {$footer in {22 23 24 25}} { + append suffix " - ::http::2 uses a separate socket" + append suffix ", other requests use a persistent connection" + } else { + } + + if {($footer >= 13 && $footer <= 23)} { + # Test use WAIT and depend on server timeout before this time. + lappend cons timeout1s + } + # ------------------------------------------------------------------ + # End of custom code. + # ------------------------------------------------------------------ + + set name "pipeline test header $header footer $footer delay $delay $tag$suffix" + + + # Here's the test: + test httpPipeline-${header}.${footer}${label}-${tag} $name \ + -constraints $cons \ + -setup [string map [list TE $te] { + # Restore default values for tests: + http::config -pipeline 1 -postfresh 0 -repost 1 + http::init + set http::http(uid) 0 + SetTestEof {TE} + }] -body [list RunTest $header $footer $delay $te] -cleanup { + # Restore default values for tests: + http::config -pipeline 1 -postfresh 0 -repost 1 + cleanupHttpTestScript + SetTestEof 0 + cleanupHttpTest + after 2000 + # Wait for persistent sockets on the server to time out. + } -result [ReturnTestResult $header $footer $delay $te] -match $match + + + } + + } + } +} + +# ------------------------------------------------------------------------------ +# (*) Notes on tests *.18*-testEof, *.19*-testEof - these test -repost 0 +# ------------------------------------------------------------------------------ +# These tests are a bit awkward because the main test kit analyses whether all +# requests are satisfied, with retries if necessary, and it has result analysis +# for processing retry logs. +# - *.18*-testEof tests that certain requests are NOT satisfied, so the analysis +# is a one-off. +# - Tests *.18a-testEof depend on client/server timing - the test needs to call +# http::geturl for all requests before the POST (request 2) is cancelled. +# We test that requests 2, 3, 4 are all cancelled. +# - Other tests *.18*-testEof may not request 3 and 4 in time for the to be +# added to the write queue before request 2 is completed. We simply check that +# request 2 is cancelled. +# - The behaviour is different if all connections are allowed to time out +# (label "j"). This case is not needed to test -repost 0, and is omitted. +# - Tests *.18*-normal and *.19* are conventional (-repost 0 should have no +# effect). +# ------------------------------------------------------------------------------ + + +unset header footer delay label suffix match cons name te +namespace delete ::httpTest +namespace delete ::httpTestScript + +::tcltest::cleanupTests diff --git a/tests/httpTest.tcl b/tests/httpTest.tcl new file mode 100644 index 0000000..326b361 --- /dev/null +++ b/tests/httpTest.tcl @@ -0,0 +1,505 @@ +# httpTest.tcl +# +# Test HTTP/1.1 concurrent requests including +# queueing, pipelining and retries. +# +# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net> +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# ------------------------------------------------------------------------------ +# "Package" httpTest for analysis of Log output of http requests. +# ------------------------------------------------------------------------------ +# This is a specialised test kit for examining the presence, ordering, and +# overlap of multiple HTTP transactions over a persistent ("Keep-Alive") +# connection; and also for testing reconnection in accordance with RFC 7230 when +# the connection is lost. +# +# This kit is probably not useful for other purposes. It depends on the +# presence of specific Log commands in the http library, and it interprets the +# logs that these commands create. +# ------------------------------------------------------------------------------ + +package require http + +namespace eval ::http { + variable TestStartTimeInMs [clock milliseconds] +# catch {puts stdout "Start time (zero ms) is $TestStartTimeInMs"} +} + +namespace eval ::httpTest { + variable testResults {} + variable testOptions + array set testOptions { + -verbose 0 + -dotted 1 + } + # -verbose - 0 quiet 1 write to stdout 2 write more + # -dotted - (boolean) use dots for absences in lists of transactions +} + +proc httpTest::Puts {txt} { + variable testOptions + if {$testOptions(-verbose) > 0} { + puts stdout $txt + flush stdout + } + return +} + +# http::Log +# +# A special-purpose logger used for running tests. +# - Processes Log calls that have "^" in their arguments, and records them in +# variable ::httpTest::testResults. +# - Also writes them to stdout (using Puts) if ($testOptions(-verbose) > 0). +# - Also writes Log calls that do not have "^", if ($testOptions(-verbose) > 1). + +proc http::Log {args} { + variable TestStartTimeInMs + set time [expr {[clock milliseconds] - $TestStartTimeInMs}] + set txt [list $time {*}$args] + if {[string first ^ $txt] != -1} { + ::httpTest::LogRecord $txt + ::httpTest::Puts $txt + } elseif {$::httpTest::testOptions(-verbose) > 1} { + ::httpTest::Puts $txt + } + return +} + + +# Called by http::Log (the "testing" version) to record logs for later analysis. + +proc httpTest::LogRecord {txt} { + variable testResults + + set pos [string first ^ $txt] + set len [string length $txt] + if {$pos > $len - 3} { + puts stdout "Logging Error: $txt" + puts stdout "Fix this call to Log in http-*.tm so it has ^ then\ + a letter then a numeral." + flush stdout + } elseif {$pos == -1} { + # Called by mistake. + } else { + set letter [string index $txt [incr pos]] + set number [string index $txt [incr pos]] + # Max 9 requests! + lappend testResults [list $letter $number] + } + + return +} + + +# ------------------------------------------------------------------------------ +# Commands for analysing the logs recorded when calling http::geturl. +# ------------------------------------------------------------------------------ + +# httpTest::TestOverlaps -- +# +# The main test for correct behaviour of pipelined and sequential +# (non-pipelined) transactions. Other tests should be run first to detect +# any inconsistencies in the data (e.g. absence of the elements that are +# examined here). +# +# Examine the sequence $someResults for each transaction from 1 to $n, +# ignoring any that are listed in $badTrans. +# Determine whether the elements "B" to $term for one transaction overlap +# elements "B" to $term for the previous and following transactions. +# +# Transactions in the list $badTrans are not included in "clean" or +# "dirty", but their possible overlap with other transactions is noted. +# Transactions in the list $notPiped are a subset of $badTrans, and +# their possible overlap with other transactions is NOT noted. +# +# Arguments: +# someResults - list of results, each of the form {letter numeral} +# n - number of HTTP transactions +# term - letter that indicated end of search range. "E" for testing +# overlaps from start of request to end of response headers. +# "F" to extend to the end of the response body. +# msg - the cumulative message from sanity checks. Append to it only +# to report a test failure. +# badTrans - list of transaction numbers not to be assessed as "clean" or +# "dirty" +# notPiped - subset of badTrans. List of transaction numbers that cannot +# taint another transaction by overlapping with it, because it +# used a different socket. +# +# Return value: [list $msg $clean $dirty] +# msg - warning messages: nothing will be appended to argument $msg if there +# is an error with the test. +# clean - list of transactions that have no overlap with other transactions +# dirty - list of transactions that have YES overlap with other transactions + +proc httpTest::TestOverlaps {someResults n term msg badTrans notPiped} { + variable testOptions + + # Check whether transactions overlap: + set clean {} + set dirty {} + for {set i 1} {$i <= $n} {incr i} { + if {$i in $badTrans} { + continue + } + set myStart [lsearch -exact $someResults [list B $i]] + set myEnd [lsearch -exact $someResults [list $term $i]] + + if {($myStart == -1 || $myEnd == -1)} { + set res "Cannot find positions of transaction $i" + append msg $res \n + Puts $res + } + + set overlaps {} + for {set j $myStart} {$j <= $myEnd} {incr j} { + lassign [lindex $someResults $j] letter number + if {$number != $i && $letter ne "A" && $number ni $notPiped} { + lappend overlaps $number + } + } + + if {[llength $overlaps] == 0} { + set res "Transaction $i has no overlaps" + Puts $res + lappend clean $i + if {$testOptions(-dotted)} { + # N.B. results from different segments are concatenated. + lappend dirty . + } else { + } + } else { + set res "Transaction $i overlaps with [join $overlaps { }]" + Puts $res + lappend dirty $i + if {$testOptions(-dotted)} { + # N.B. results from different segments are concatenated. + lappend clean . + } else { + } + } + } + return [list $msg $clean $dirty] +} + +# httpTest::PipelineNext -- +# +# Test whether prevPair, pair are valid as consecutive elements of a pipelined +# sequence (Start 1), (End 1), (Start 2), (End 2) ... +# Numbers are integers increasing (by 1 if argument "any" is false), and need +# not begin with 1. +# The first element of the sequence has prevPair {} and is always passed as +# valid. +# +# Arguments; +# Start - string that labels the start of a segment +# End - string that labels the end of a segment +# prevPair - previous "pair" (list of string and number) element of a +# sequence, or {} if argument "pair" is the first in the +# sequence. +# pair - current "pair" (list of string and number) element of a +# sequence +# any - (boolean) iff true, accept any increasing sequence of integers. +# If false, integers must increase by 1. +# +# Return value - boolean, true iff the two pairs are valid consecutive elements. + +proc httpTest::PipelineNext {Start End prevPair pair any} { + if {$prevPair eq {}} { + return 1 + } + + lassign $prevPair letter number + lassign $pair newLetter newNumber + if {$letter eq $Start} { + return [expr {($newLetter eq $End) && ($newNumber == $number)}] + } elseif {$any} { + set nxt [list $Start [expr {$number + 1}]] + return [expr {($newLetter eq $Start) && ($newNumber > $number)}] + } else { + set nxt [list $Start [expr {$number + 1}]] + return [expr {($newLetter eq $Start) && ($newNumber == $number + 1)}] + } +} + +# httpTest::TestPipeline -- +# +# Given a sequence of "pair" elements, check that the elements whose string is +# $Start or $End form a valid pipeline. Ignore other elements. +# +# Return value: {} if valid pipeline, otherwise a non-empty error message. + +proc httpTest::TestPipeline {someResults n Start End msg desc badTrans} { + set sequence {} + set prevPair {} + set ok 1 + set any [llength $badTrans] + foreach pair $someResults { + lassign $pair letter number + if {($letter in [list $Start $End]) && ($number ni $badTrans)} { + lappend sequence $pair + if {![PipelineNext $Start $End $prevPair $pair $any]} { + set ok 0 + break + } + set prevPair $pair + } + } + + if {!$ok} { + set res "$desc are not pipelined: {$sequence}" + append msg $res \n + Puts $res + } + return $msg +} + +# httpTest::TestSequence -- +# +# Examine each transaction from 1 to $n, ignoring any that are listed +# in $badTrans. +# Check that each transaction has elements A to F, in alphabetical order. + +proc httpTest::TestSequence {someResults n msg badTrans} { + variable testOptions + + for {set i 1} {$i <= $n} {incr i} { + if {$i in $badTrans} { + continue + } + set sequence {} + foreach pair $someResults { + lassign $pair letter number + if {$number == $i} { + lappend sequence $letter + } + } + if {$sequence eq {A B C D E F}} { + } else { + set res "Wrong sequence for token ::http::$i - {$sequence}" + append msg $res \n + Puts $res + if {"X" in $sequence} { + set res "- and error(s) X" + append msg $res \n + Puts $res + } + if {"Y" in $sequence} { + set res "- and warnings(s) Y" + append msg $res \n + Puts $res + } + } + } + return $msg +} + +# +# Arguments: +# someResults - list of elements, each a list of a letter and a number +# n - (positive integer) the number of HTTP requests +# msg - accumulated warning messages +# skipOverlaps - (boolean) whether to skip testing of transaction overlaps +# badTrans - list of transaction numbers not to be assessed as "clean" or +# "dirty" by their overlaps +# for 1/2 includes all transactions +# for 3/4 includes an increasing (with recursion) set that will not be included in the list because they are already handled. +# notPiped - subset of badTrans. List of transaction numbers that cannot +# taint another transaction by overlapping with it, because it +# used a different socket. +# +# Return value: [list $msg $cleanE $cleanF $dirtyE $dirtyF] +# msg - warning messages: nothing will be appended to argument $msg if there +# is no error with the test. +# cleanE - list of transactions that have no overlap with other transactions +# (not considering response body) +# dirtyE - list of transactions that have YES overlap with other transactions +# (not considering response body) +# cleanF - list of transactions that have no overlap with other transactions +# (including response body) +# dirtyF - list of transactions that have YES overlap with other transactions +# (including response body) + +proc httpTest::MostAnalysis {someResults n msg skipOverlaps badTrans notPiped} { + variable testOptions + + # Check that stages for "good" transactions are all present and correct: + set msg [TestSequence $someResults $n $msg $badTrans] + + # Check that requests are pipelined: + set msg [TestPipeline $someResults $n B C $msg Requests $notPiped] + + # Check that responses are pipelined: + set msg [TestPipeline $someResults $n D F $msg Responses $notPiped] + + if {$skipOverlaps} { + set cleanE {} + set dirtyE {} + set cleanF {} + set dirtyF {} + } else { + Puts "Overlaps including response body (test for non-pipelined case)" + lassign [TestOverlaps $someResults $n F $msg $badTrans $notPiped] msg cleanF dirtyF + + Puts "Overlaps without response body (test for pipelined case)" + lassign [TestOverlaps $someResults $n E $msg $badTrans $notPiped] msg cleanE dirtyE + } + + return [list $msg $cleanE $cleanF $dirtyE $dirtyF] +} + +# httpTest::ProcessRetries -- +# +# Command to examine results for socket-changing records [PQR], +# divide the results into segments for each connection, and analyse each segment +# individually. +# (Could add $sock to the logging to simplify this, but never mind.) +# +# In each segment, identify any transactions that are not included, and +# any that are aborted, to assist subsequent testing. +# +# Prepend A records (socket-independent) to each segment for transactions that +# were scheduled (by A) but not completed (by F). Pass each segment to +# MostAnalysis for processing. + +proc httpTest::ProcessRetries {someResults n msg skipOverlaps notIncluded notPiped} { + variable testOptions + + set nextRetry [lsearch -glob -index 0 $someResults {[PQR]}] + if {$nextRetry == -1} { + return [MostAnalysis $someResults $n $msg $skipOverlaps $notIncluded $notPiped] + } + set badTrans $notIncluded + set tryCount 0 + set try $nextRetry + incr tryCount + lassign [lindex $someResults $try] letter number + Puts "Processing retry [lindex $someResults $try]" + set beforeTry [lrange $someResults 0 $try-1] + Puts [join $beforeTry \n] + set afterTry [lrange $someResults $try+1 end] + + set dummyTry {} + for {set i 1} {$i <= $n} {incr i} { + set first [lsearch -exact $beforeTry [list A $i]] + set last [lsearch -exact $beforeTry [list F $i]] + if {$first == -1} { + set res "Transaction $i was not started in connection number $tryCount" + # So lappend it to badTrans and don't include it in the call below of MostAnalysis. + # append msg $res \n + Puts $res + if {$i ni $badTrans} { + lappend badTrans $i + } else { + } + } elseif {$last == -1} { + set res "Transaction $i was started but unfinished in connection number $tryCount" + # So lappend it to badTrans and don't include it in the call below of MostAnalysis. + # append msg $res \n + Puts $res + lappend badTrans $i + lappend dummyTry [list A $i] + } else { + set res "Transaction $i was started and finished in connection number $tryCount" + # So include it in the call below of MostAnalysis. + # So lappend it to notIncluded and don't include it in the recursive call of + # ProcessRetries which handles the later connections. + # append msg $res \n + Puts $res + lappend notIncluded $i + } + } + + # Analyse the part of the results before the first replay: + set HeadResults [MostAnalysis $beforeTry $n $msg $skipOverlaps $badTrans $notPiped] + lassign $HeadResults msg cleanE1 cleanF1 dirtyE1 dirtyF1 + + # Pass the rest of the results to be processed recursively. + set afterTry [concat $dummyTry $afterTry] + set TailResults [ProcessRetries $afterTry $n $msg $skipOverlaps $notIncluded $notPiped] + lassign $TailResults msg cleanE2 cleanF2 dirtyE2 dirtyF2 + + set cleanE [concat $cleanE1 $cleanE2] + set cleanF [concat $cleanF1 $cleanF2] + set dirtyE [concat $dirtyE1 $dirtyE2] + set dirtyF [concat $dirtyF1 $dirtyF2] + return [list $msg $cleanE $cleanF $dirtyE $dirtyF] +} + +# httpTest::logAnalyse -- +# +# The main command called to analyse logs for a single test. +# +# Arguments: +# n - (positive integer) the number of HTTP requests +# skipOverlaps - (boolean) whether to skip testing of transaction overlaps +# notIncluded - list of transaction numbers not to be assessed as "clean" or +# "dirty" by their overlaps +# notPiped - subset of notIncluded. List of transaction numbers that cannot +# taint another transaction by overlapping with it, because it +# used a different socket. +# +# Return value: [list $msg $cleanE $cleanF $dirtyE $dirtyF] +# msg - warning messages: {} if there is no error with the test. +# cleanE - list of transactions that have no overlap with other transactions +# (not considering response body) +# dirtyE - list of transactions that have YES overlap with other transactions +# (not considering response body) +# cleanF - list of transactions that have no overlap with other transactions +# (including response body) +# dirtyF - list of transactions that have YES overlap with other transactions +# (including response body) + +proc httpTest::logAnalyse {n skipOverlaps notIncluded notPiped} { + variable testResults + variable testOptions + + # Check that each data item has the correct form {letter numeral}. + set ii 0 + set ok 1 + foreach pair $testResults { + lassign $pair letter number + if { [string match {[A-Z]} $letter] + && [string match {[0-9]} $number] + } { + # OK + } else { + set ok 0 + set res "Error: testResults has bad element {$pair} at position $ii" + append msg $res \n + Puts $res + } + incr ii + } + + if {!$ok} { + return $msg + } + set msg {} + + Puts [join $testResults \n] + ProcessRetries $testResults $n $msg $skipOverlaps $notIncluded $notPiped + # N.B. Implicit Return. +} + +proc httpTest::cleanupHttpTest {} { + variable testResults + set testResults {} + return +} + +proc httpTest::setHttpTestOptions {key args} { + variable testOptions + if {$key ni {-dotted -verbose}} { + return -code error {valid options are -dotted, -verbose} + } + set testOptions($key) {*}$args +} + +namespace eval httpTest { + namespace export cleanupHttpTest logAnalyse setHttpTestOptions +} diff --git a/tests/httpTestScript.tcl b/tests/httpTestScript.tcl new file mode 100644 index 0000000..a40449a --- /dev/null +++ b/tests/httpTestScript.tcl @@ -0,0 +1,509 @@ +# httpTestScript.tcl +# +# Test HTTP/1.1 concurrent requests including +# queueing, pipelining and retries. +# +# Copyright (C) 2018 Keith Nash <kjnash@users.sourceforge.net> +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# ------------------------------------------------------------------------------ +# "Package" httpTestScript for executing test scripts written in a convenient +# shorthand. +# ------------------------------------------------------------------------------ + +# ------------------------------------------------------------------------------ +# Documentation for "package" httpTestScript. +# ------------------------------------------------------------------------------ +# To use the package: +# (a) define URLs as the values of elements in the array ::httpTestScript +# (b) define a script in terms of the commands +# START STOP DELAY KEEPALIVE WAIT PIPELINE GET HEAD POST +# referring to URLs by the name of the corresponding array element. The +# script can include any other Tcl commands, and evaluates in the +# httpTestScript namespace. +# (c) Use the command httpTestScript::runHttpTestScript to evaluate the script. +# (d) For tcltest tests, wrap the runHttpTestScript call in a suitable "test" +# command. +# ------------------------------------------------------------------------------ +# START +# Must be the first command of the script. +# +# STOP +# Must be present in the script to avoid waiting for client timeout. +# Usually the last command, but can be elsewhere to end a script prematurely. +# Subsequent httpTestScript commands will have no effect. +# +# DELAY ms +# If there are no WAIT commands, this sets the delay in ms between subsequent +# calls to http::geturl. Default 500ms. +# +# KEEPALIVE +# Set the value passed to http::geturl for the -keepalive option. The command +# applies to subsequent requests in the script. Default 1. +# +# WAIT ms +# Pause for a time in ms before sending subsequent requests. +# +# PIPELINE boolean +# Set the value of -pipeline using http::config. The last PIPELINE command +# in the script applies to every request. Default 1. +# +# POSTFRESH boolean +# Set the value of -postfresh using http::config. The last POSTFRESH command +# in the script applies to every request. Default 0. +# +# REPOST boolean +# Set the value of -repost using http::config. The last REPOST command +# in the script applies to every request. Default 1 for httpTestScript. +# (Default value in http is 0). +# +# GET uriCode ?arg ...? +# Send a HTTP request using the GET method. +# Arguments: +# uriCode - the code for the base URI - the value must be stored in +# ::httpTestScript::URL($uriCode). +# args - strings that will be joined by "&" and appended to the query +# string with a preceding "&". +# +# HEAD uriCode ?arg ...? +# Send a HTTP request using the HEAD method. +# Arguments: as for GET +# +# POST uriCode ?arg ...? +# Send a HTTP request using the POST method. +# Arguments: +# uriCode - the code for the base URI - the value must be stored in +# ::httpTestScript::URL($uriCode). +# args - strings that will be joined by "&" and used as the request body. +# ------------------------------------------------------------------------------ + +namespace eval ::httpTestScript { + namespace export runHttpTestScript cleanupHttpTestScript +} + +# httpTestScript::START -- +# Initialise, and create a long-stop timeout. + +proc httpTestScript::START {} { + variable CountRequestedSoFar + variable RequestsWhenStopped + variable KeepAlive + variable Delay + variable TimeOutCode + variable TimeOutDone + variable StartDone + variable StopDone + variable CountFinishedSoFar + variable RequestList + variable RequestsMade + variable ExtraTime + variable ActualKeepAlive + + if {[info exists StartDone] && ($StartDone == 1)} { + set msg {START has been called twice without an intervening STOP} + return -code error $msg + } + + set StartDone 1 + set StopDone 0 + set TimeOutDone 0 + set CountFinishedSoFar 0 + set CountRequestedSoFar 0 + set RequestList {} + set RequestsMade {} + set ExtraTime 0 + set ActualKeepAlive 1 + + # Undefined until a STOP command: + unset -nocomplain RequestsWhenStopped + + # Default values: + set KeepAlive 1 + set Delay 500 + + # Default values for tests: + KEEPALIVE 1 + PIPELINE 1 + POSTFRESH 0 + REPOST 1 + + set TimeOutCode [after 30000 httpTestScript::TimeOutNow] +# set TimeOutCode [after 4000 httpTestScript::TimeOutNow] + return +} + +# httpTestScript::STOP -- +# Do not process any more commands. The commands will be executed but will +# silently do nothing. + +proc httpTestScript::STOP {} { + variable CountRequestedSoFar + variable CountFinishedSoFar + variable RequestsWhenStopped + variable TimeOutCode + variable StartDone + variable StopDone + variable RequestsMade + + if {$StopDone} { + # Don't do anything on a second call. + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + set StopDone 1 + set StartDone 0 + set RequestsWhenStopped $CountRequestedSoFar + unset -nocomplain StartDone + + if {$CountFinishedSoFar == $RequestsWhenStopped} { + if {[info exists TimeOutCode]} { + after cancel $TimeOutCode + } + set ::httpTestScript::FOREVER 0 + } + return +} + +# httpTestScript::DELAY -- +# If there are no WAIT commands, this sets the delay in ms between subsequent +# calls to http::geturl. Default 500ms. + +proc httpTestScript::DELAY {t} { + variable StartDone + variable StopDone + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + variable Delay + + set Delay $t + return +} + +# httpTestScript::KEEPALIVE -- +# Set the value passed to http::geturl for the -keepalive option. Default 1. + +proc httpTestScript::KEEPALIVE {b} { + variable StartDone + variable StopDone + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + variable KeepAlive + set KeepAlive $b + return +} + +# httpTestScript::WAIT -- +# Pause for a time in ms before processing any more commands. + +proc httpTestScript::WAIT {t} { + variable StartDone + variable StopDone + variable ExtraTime + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + if {(![string is integer -strict $t]) || $t < 0} { + return -code error {argument to WAIT must be a non-negative integer} + } + + incr ExtraTime $t + + return +} + +# httpTestScript::PIPELINE -- +# Pass a value to http::config -pipeline. + +proc httpTestScript::PIPELINE {b} { + variable StartDone + variable StopDone + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + ::http::config -pipeline $b + ##::http::Log http(-pipeline) is now [::http::config -pipeline] + return +} + +# httpTestScript::POSTFRESH -- +# Pass a value to http::config -postfresh. + +proc httpTestScript::POSTFRESH {b} { + variable StartDone + variable StopDone + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + ::http::config -postfresh $b + ##::http::Log http(-postfresh) is now [::http::config -postfresh] + return +} + +# httpTestScript::REPOST -- +# Pass a value to http::config -repost. + +proc httpTestScript::REPOST {b} { + variable StartDone + variable StopDone + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + ::http::config -repost $b + ##::http::Log http(-repost) is now [::http::config -repost] + return +} + +# httpTestScript::GET -- +# Send a HTTP request using the GET method. +# Arguments: +# uriCode - the code for the base URI - the value must be stored in +# ::httpTestScript::URL($uriCode). +# args - strings that will each be preceded by "&" and appended to the query +# string. + +proc httpTestScript::GET {uriCode args} { + variable RequestList + lappend RequestList GET + RequestAfter $uriCode 0 {} {*}$args + return +} + +# httpTestScript::HEAD -- +# Send a HTTP request using the HEAD method. +# Arguments: as for GET + +proc httpTestScript::HEAD {uriCode args} { + variable RequestList + lappend RequestList HEAD + RequestAfter $uriCode 1 {} {*}$args + return +} + +# httpTestScript::POST -- +# Send a HTTP request using the POST method. +# Arguments: +# uriCode - the code for the base URI - the value must be stored in +# ::httpTestScript::URL($uriCode). +# args - strings that will be joined by "&" and used as the request body. + +proc httpTestScript::POST {uriCode args} { + variable RequestList + lappend RequestList POST + RequestAfter $uriCode 0 {use} {*}$args + return +} + + +proc httpTestScript::RequestAfter {uriCode validate query args} { + variable CountRequestedSoFar + variable Delay + variable ExtraTime + variable StartDone + variable StopDone + variable KeepAlive + + if {$StopDone} { + return + } + + if {![info exists StartDone]} { + return -code error {initialise the script by calling command START} + } + + incr CountRequestedSoFar + set idelay [expr {($CountRequestedSoFar - 1) * $Delay + 10 + $ExtraTime}] + + # Could pass values of -pipeline, -postfresh, -repost if it were + # useful to change these mid-script. + after $idelay [list httpTestScript::Requester $uriCode $KeepAlive $validate $query {*}$args] + return +} + +proc httpTestScript::Requester {uriCode keepAlive validate query args} { + variable URL + + ::http::config -accept {*/*} + + set absUrl $URL($uriCode) + if {$query eq {}} { + if {$args ne {}} { + append absUrl & [join $args &] + } + set queryArgs {} + } elseif {$validate} { + return -code error {cannot have both -validate (HEAD) and -query (POST)} + } else { + set queryArgs [list -query [join $args &]] + } + + if {[catch { + ::http::geturl $absUrl \ + -validate $validate \ + -timeout 10000 \ + {*}$queryArgs \ + -keepalive $keepAlive \ + -command ::httpTestScript::WhenFinished + } token]} { + set msg $token + catch {puts stdout "Error: $msg"} + return + } else { + # Request will begin. + } + + return + +} + +proc httpTestScript::TimeOutNow {} { + variable TimeOutDone + + set TimeOutDone 1 + set ::httpTestScript::FOREVER 0 + return +} + +proc httpTestScript::WhenFinished {hToken} { + variable CountFinishedSoFar + variable RequestsWhenStopped + variable TimeOutCode + variable StopDone + variable RequestList + variable RequestsMade + variable ActualKeepAlive + + upvar #0 $hToken state + + if {[catch { + if { [info exists state(transfer)] + && ($state(transfer) eq "chunked") + } { + set Trans chunked + } else { + set Trans unchunked + } + + if { [info exists ::httpTest::testOptions(-verbose)] + && ($::httpTest::testOptions(-verbose) > 0) + } { + puts "Token $hToken +Response $state(http) +Status $state(status) +Method $state(method) +Transfer $Trans +Size $state(currentsize) +URL $state(url) +" + } + + if {!$state(-keepalive)} { + set ActualKeepAlive 0 + } + + if {[info exists state(method)]} { + lappend RequestsMade $state(method) + } else { + lappend RequestsMade UNKNOWN + } + set tk [namespace tail $hToken] + + if { ($state(http) != {HTTP/1.1 200 OK}) + || ($state(status) != {ok}) + || (($state(currentsize) == 0) && ($state(method) ne "HEAD")) + } { + ::http::Log ^X$tk unexpected result Response $state(http) Status $state(status) Size $state(currentsize) - token $hToken + } + } err]} { + ::http::Log ^X$tk httpTestScript::WhenFinished failed with error status: $err - token $hToken + } + + incr CountFinishedSoFar + if {$StopDone && ($CountFinishedSoFar == $RequestsWhenStopped)} { + if {[info exists TimeOutCode]} { + after cancel $TimeOutCode + } + if {$RequestsMade ne $RequestList && $ActualKeepAlive} { + ::http::Log ^X$tk unexpected result - Script asked for "{$RequestList}" but got "{$RequestsMade}" - token $hToken + } + set ::httpTestScript::FOREVER 0 + } + + return +} + + +proc httpTestScript::runHttpTestScript {scr} { + variable TimeOutDone + variable RequestsWhenStopped + + after idle [list namespace eval ::httpTestScript $scr] + vwait ::httpTestScript::FOREVER + # N.B. does not automatically execute in this namespace, unlike some other events. + # Release when all requests have been served or have timed out. + + if {$TimeOutDone} { + return -code error {test script timed out} + } + + return $RequestsWhenStopped +} + + +proc httpTestScript::cleanupHttpTestScript {} { + variable TimeOutDone + variable RequestsWhenStopped + + if {![info exists RequestsWhenStopped]} { + return -code error {Cleanup Failed: RequestsWhenStopped is undefined} + } + + for {set i 1} {$i <= $RequestsWhenStopped} {incr i} { + http::cleanup ::http::$i + } + + return +} diff --git a/tests/info.test b/tests/info.test index 8176ad3..a12d45c 100644 --- a/tests/info.test +++ b/tests/info.test @@ -19,9 +19,9 @@ if {{::tcltest} ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* } - ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] +testConstraint zlib [llength [info commands zlib]] # Set up namespaces needed to test operation of "info args", "info body", # "info default", and "info procs" with imported procedures. @@ -33,7 +33,7 @@ namespace eval test_ns_info1 { proc p {x} {return "x=$x"} proc q {{y 27} {z {}}} {return "y=$y"} } - + test info-1.1 {info args option} { proc t1 {a bbb c} {return foo} info args t1 @@ -110,7 +110,7 @@ test info-2.6 {info body option, returning list bodies} { proc testinfocmdcount {} { set x [info cmdcount] set y 12345 - set z [info cm] + set z [info cmdc] expr {$z-$x} } test info-3.1 {info cmdcount compiled} { @@ -119,7 +119,7 @@ test info-3.1 {info cmdcount compiled} { test info-3.2 {info cmdcount evaled} -body { set x [info cmdcount] set y 12345 - set z [info cm] + set z [info cmdc] expr {$z-$x} } -cleanup {unset x y z} -result 4 test info-3.3 {info cmdcount evaled} -body [info body testinfocmdcount] -cleanup {unset x y z} -result 4 @@ -678,16 +678,16 @@ test info-21.1 {miscellaneous error conditions} -returnCodes error -body { } -result {wrong # args: should be "info subcommand ?arg ...?"} test info-21.2 {miscellaneous error conditions} -returnCodes error -body { info gorp -} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.3 {miscellaneous error conditions} -returnCodes error -body { info c -} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.4 {miscellaneous error conditions} -returnCodes error -body { info l -} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} test info-21.5 {miscellaneous error conditions} -returnCodes error -body { info s -} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} +} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars} ## # ### ### ### ######### ######### ######### @@ -2396,6 +2396,174 @@ test info-33.35 {{*}, literal, simple, bytecompiled} -body { } -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- +namespace eval ::testinfocmdtype { + apply {cmds { + foreach c $cmds {rename $c {}} + } ::testinfocmdtype} [info commands ::testinfocmdtype::*] +} +test info-40.1 {info cmdtype: syntax} -body { + info cmdtype +} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"} +test info-40.2 {info cmdtype: syntax} -body { + info cmdtype foo bar +} -returnCodes error -result {wrong # args: should be "info cmdtype commandName"} +test info-40.3 {info cmdtype: no such command} -body { + info cmdtype ::testinfocmdtype::foo +} -returnCodes error -result {unknown command "::testinfocmdtype::foo"} +test info-40.4 {info cmdtype: native commands} -body { + info cmdtype ::if +} -result native +test info-40.5 {info cmdtype: native commands} -body { + info cmdtype ::puts +} -result native +test info-40.6 {info cmdtype: native commands} -body { + info cmdtype ::yield +} -result native +test info-40.7 {info cmdtype: procedures} -setup { + proc ::testinfocmdtype::someproc {} {} +} -body { + info cmdtype ::testinfocmdtype::someproc +} -cleanup { + rename ::testinfocmdtype::someproc {} +} -result proc +test info-40.8 {info cmdtype: aliases} -setup { + interp alias {} ::testinfocmdtype::somealias {} ::puts +} -body { + info cmdtype ::testinfocmdtype::somealias +} -cleanup { + rename ::testinfocmdtype::somealias {} +} -result alias +test info-40.9 {info cmdtype: imports} -setup { + namespace eval ::testinfocmdtype { + namespace eval foo { + proc bar {} {} + namespace export bar + } + namespace import foo::bar + } +} -body { + info cmdtype ::testinfocmdtype::bar +} -cleanup { + rename ::testinfocmdtype::bar {} + namespace delete ::testinfocmdtype::foo +} -result import +test info-40.10 {info cmdtype: slaves} -setup { + apply {i { + rename $i ::testinfocmdtype::slave + variable ::testinfocmdtype::slave $i + }} [interp create] +} -body { + info cmdtype ::testinfocmdtype::slave +} -cleanup { + interp delete $::testinfocmdtype::slave +} -result slave +test info-40.11 {info cmdtype: objects} -setup { + apply {{} { + oo::object create obj + } ::testinfocmdtype} +} -body { + info cmdtype ::testinfocmdtype::obj +} -cleanup { + ::testinfocmdtype::obj destroy +} -result object +test info-40.12 {info cmdtype: objects} -setup { + apply {{} { + oo::object create obj + } ::testinfocmdtype} +} -body { + info cmdtype [info object namespace ::testinfocmdtype::obj]::my +} -cleanup { + ::testinfocmdtype::obj destroy +} -result privateObject +test info-40.13 {info cmdtype: ensembles} -setup { + namespace eval ::testinfocmdtype { + namespace eval ensmbl { + proc bar {} {} + namespace export * + namespace ensemble create + } + } +} -body { + info cmdtype ::testinfocmdtype::ensmbl +} -cleanup { + namespace delete ::testinfocmdtype::ensmbl +} -result ensemble +test info-40.14 {info cmdtype: zlib streams} -constraints zlib -setup { + namespace eval ::testinfocmdtype { + rename [zlib stream gzip] zstream + } +} -body { + info cmdtype ::testinfocmdtype::zstream +} -cleanup { + ::testinfocmdtype::zstream close +} -result zlibStream +test info-40.15 {info cmdtype: coroutines} -setup { + coroutine ::testinfocmdtype::coro eval yield +} -body { + info cmdtype ::testinfocmdtype::coro +} -cleanup { + ::testinfocmdtype::coro +} -result coroutine +test info-40.16 {info cmdtype: dynamic behavior} -setup { + proc ::testinfocmdtype::foo {} {} +} -body { + namespace eval ::testinfocmdtype { + list [catch {info cmdtype foo}] [catch {info cmdtype bar}] \ + [namespace which foo] [rename foo bar] [namespace which bar] \ + [catch {info cmdtype foo}] [catch {info cmdtype bar}] + } +} -cleanup { + namespace eval ::testinfocmdtype { + catch {rename foo {}} + catch {rename bar {}} + } +} -result {0 1 ::testinfocmdtype::foo {} ::testinfocmdtype::bar 1 0} +test info-40.17 {info cmdtype: aliases in slave interpreters} -setup { + set i [interp create] +} -body { + $i alias foo gorp + $i eval { + info cmdtype foo + } +} -cleanup { + interp delete $i +} -result alias +test info-40.18 {info cmdtype: aliases in slave interpreters} -setup { + set safe [interp create -safe] +} -body { + $safe alias foo gorp + $safe eval { + info cmdtype foo + } +} -returnCodes error -cleanup { + interp delete $safe +} -result {not allowed to invoke subcommand cmdtype of info} +test info-40.19 {info cmdtype: aliases in slave interpreters} -setup { + set safe [interp create -safe] +} -body { + set inner [interp create [list $safe bar]] + interp alias $inner foo $safe gorp + $safe eval { + bar eval { + info cmdtype foo + } + } +} -returnCodes error -cleanup { + interp delete $safe +} -result {not allowed to invoke subcommand cmdtype of info} +test info-40.20 {info cmdtype: aliases in slave interpreters} -setup { + set safe [interp create -safe] +} -body { + $safe eval { + interp alias {} foo {} gorp + info cmdtype foo + } +} -returnCodes error -cleanup { + interp delete $safe +} -result {not allowed to invoke subcommand cmdtype of info} +namespace delete ::testinfocmdtype + +# ------------------------------------------------------------------------- unset -nocomplain res test info-39.2 {Bug 4b61afd660} -setup { diff --git a/tests/interp.test b/tests/interp.test index 4ea04e3..29e3b2d 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -20,7 +20,7 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testinterpdelete [llength [info commands testinterpdelete]] -set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload} +set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload} foreach i [interp slaves] { interp delete $i diff --git a/tests/io.test b/tests/io.test index 20bb565..683a1b2 100644 --- a/tests/io.test +++ b/tests/io.test @@ -15,14 +15,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 - namespace import -force ::tcltest::* } -::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] - -testConstraint testbytestring [llength [info commands testbytestring]] - namespace eval ::tcl::test::io { namespace import ::tcltest::* @@ -35,15 +29,16 @@ namespace eval ::tcl::test::io { variable msg variable expected + loadTestedCommands + catch [list package require -exact Tcltest [info patchlevel]] + package require tcltests + +testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testchannel [llength [info commands testchannel]] -testConstraint exec [llength [info commands exec]] testConstraint openpipe 1 -testConstraint fileevent [llength [info commands fileevent]] -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 thread [expr {0 == [catch {package require Thread 2.7-}]}] testConstraint testobj [llength [info commands testobj]] # You need a *very* special environment to do some tests. In diff --git a/tests/ioCmd.test b/tests/ioCmd.test index cab4e97..948671e 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -21,10 +21,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] +package require tcltests + # Custom constraints used in this file -testConstraint fcopy [llength [info commands fcopy]] testConstraint testchannel [llength [info commands testchannel]] -testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] #---------------------------------------------------------------------- @@ -395,7 +395,7 @@ test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} { test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} { list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode } {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}} -test iocmd-11.4 {I/O to command pipelines} unixOrPc { +test iocmd-11.4 {I/O to command pipelines} {notValgrind unixOrPc} { list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode } {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}} @@ -3781,7 +3781,6 @@ test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body { # Use constraints to skip this test while valgrinding so this expected leak # doesn't prevent a finding of "leak-free". # -testConstraint notValgrind [expr {![testConstraint valgrind]}] test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -match glob -body { #puts <<$tcltest::mainThread>>main @@ -3834,6 +3833,16 @@ test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -mat rename track {} # cleanup + + +# Eliminate valgrind "still reachable" reports on outstanding "Detached" +# structures in the detached list which stem from PipeClose2Proc not waiting +# around for background processes to complete, meaning that previous calls to +# Tcl_ReapDetachedProcs might not have had a chance to reap all processes. +after 10 +exec [info nameofexecutable] << {} + + foreach file [list test1 test2 test3 test4] { removeFile $file } diff --git a/tests/ioTrans.test b/tests/ioTrans.test index 75752f7..0a335ff 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -1240,8 +1240,8 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces set res }] } -cleanup { - tempdone interp delete $idb + tempdone } -result {Owner lost} test iortrans-11.2 {delete interp of reflected transform} -setup { interp create slave diff --git a/tests/iogt.test b/tests/iogt.test index aa579bf..3cac2cf 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -608,7 +608,7 @@ test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup { variable copy 1 } } -constraints {testchannel knownBug} -body { - # This test to check the validity of aquired Tcl_Channel references is not + # This test to check the validity of acquired Tcl_Channel references is not # possible because even a backgrounded fcopy will immediately start to # copy data, without waiting for the event loop. This is done only in case # of an underflow on the read size!. So stacking transforms after the diff --git a/tests/lreplace.test b/tests/lreplace.test index 4a6b853..fd2f7f8 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -100,10 +100,10 @@ test lreplace-1.26 {lreplace command} { } {a {} {}} test lreplace-1.27 {lreplace command} -body { lreplace x 1 1 -} -returnCodes 1 -result {list doesn't contain element 1} +} -result x test lreplace-1.28 {lreplace command} -body { lreplace x 1 1 y -} -returnCodes 1 -result {list doesn't contain element 1} +} -result {x y} test lreplace-1.29 {lreplace command} -body { lreplace x 1 1 [error foo] } -returnCodes 1 -result {foo} @@ -128,10 +128,10 @@ test lreplace-2.5 {lreplace errors} { } {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}} test lreplace-2.6 {lreplace errors} { list [catch {lreplace x 3 2} msg] $msg -} {1 {list doesn't contain element 3}} +} {0 x} test lreplace-2.7 {lreplace errors} { list [catch {lreplace x 2 2} msg] $msg -} {1 {list doesn't contain element 2}} +} {0 x} test lreplace-3.1 {lreplace won't modify shared argument objects} { proc p {} { diff --git a/tests/macOSXFCmd.test b/tests/macOSXFCmd.test index 071f11b..f1758f5 100644 --- a/tests/macOSXFCmd.test +++ b/tests/macOSXFCmd.test @@ -99,7 +99,7 @@ test macOSXFCmd-2.6 {MacOSXSetFileAttribute - hidden} {macosxFileAttr notRoot} { [catch {file attributes foo.test -hidden} msg] $msg \ [file delete -force -- foo.test] } {0 {} 0 1 {}} -test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoot} { +test macOSXFCmd-2.7 {MacOSXSetFileAttribute - rsrclength} {macosxFileAttr notRoot nonPortable} { catch {file delete -force -- foo.test} close [open foo.test w] catch { @@ -151,16 +151,16 @@ test macOSXFCmd-4.1 {TclMacOSXMatchType} {macosxFileAttr notRoot} { file attributes dir.test -hidden 1 } set res [list \ - [catch {glob *.test} msg] $msg \ - [catch {glob -types FOOT *.test} msg] $msg \ - [catch {glob -types {{macintosh type FOOT}} *.test} msg] $msg \ - [catch {glob -types FOOTT *.test} msg] $msg \ - [catch {glob -types {{macintosh type FOOTT}} *.test} msg] $msg \ - [catch {glob -types {{macintosh type {}}} *.test} msg] $msg \ - [catch {glob -types {{macintosh creator FOOC}} *.test} msg] $msg \ - [catch {glob -types {{macintosh creator FOOC} {macintosh type FOOT}} *.test} msg] $msg \ - [catch {glob -types hidden *.test} msg] $msg \ - [catch {glob -types {hidden FOOT} *.test} msg] $msg \ + [catch {lsort [glob *.test]} msg] $msg \ + [catch {lsort [glob -types FOOT *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh type FOOT}} *.test]} msg] $msg \ + [catch {lsort [glob -types FOOTT *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh type FOOTT}} *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh type {}}} *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh creator FOOC}} *.test]} msg] $msg \ + [catch {lsort [glob -types {{macintosh creator FOOC} {macintosh type FOOT}} *.test]} msg] $msg \ + [catch {lsort [glob -types hidden *.test]} msg] $msg \ + [catch {lsort [glob -types {hidden FOOT} *.test]} msg] $msg \ ] cd .. file delete -force globtest diff --git a/tests/main.test b/tests/main.test index ab66b38..5b43b43 100644 --- a/tests/main.test +++ b/tests/main.test @@ -1210,8 +1210,6 @@ namespace eval ::tcl::test::main { Bug 1775878 } -constraints { exec Tcltest - } -setup { - catch {set f [open "|[list [interpreter]]" w+]} } -body { exec [interpreter] << "testsetmainloop\nputs \\\npwd\ntestexitmainloop" >& result set f [open result] diff --git a/tests/msgcat.test b/tests/msgcat.test index 12030fb..3dde124 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -999,7 +999,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { mcpackagelocale isset } -result {0} - + # Tests msgcat-13.*: [mcpackageconfig subcmds] test msgcat-13.1 {mcpackageconfig no subcommand} -body { @@ -1153,7 +1153,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { # Tests msgcat-15.*: tcloo coverage - + # There are 4 use-cases, where 3 must be tested now: # - namespace defined, in class definition, class defined oo, classless @@ -1210,7 +1210,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { } -body { bar::ObjCur method1 } -result con2bar - + test msgcat-15.4 {mc in classless object with explicite namespace eval}\ -setup { # full namespace is ::msgcat::test:bar @@ -1236,7 +1236,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { } -body { bar::ObjCur method1 } -result con2baz - + # Test msgcat-16.*: command mcpackagenamespaceget test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body { @@ -1298,7 +1298,7 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { # Test msgcat-17.*: mcn command - + test msgcat-17.1 {mcn no parameters} -body { mcn } -returnCodes 1\ @@ -1328,26 +1328,26 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { mcutil junk } -returnCodes 1\ -result {unknown subcommand "junk": must be getpreferences, or getsystemlocale} - + test msgcat-18.3 {mcutil - partial argument} -body { mcutil getsystem } -returnCodes 1\ -result {unknown subcommand "getsystem": must be getpreferences, or getsystemlocale} - + test msgcat-18.4 {mcutil getpreferences - no argument} -body { mcutil getpreferences } -returnCodes 1\ -result {wrong # args: should be "mcutil getpreferences locale"} - + test msgcat-18.5 {mcutil getpreferences - DE_de} -body { mcutil getpreferences DE_de } -result {de_de de {}} - + test msgcat-18.6 {mcutil getsystemlocale - wrong argument} -body { mcutil getsystemlocale DE_de } -returnCodes 1\ -result {wrong # args: should be "mcutil getsystemlocale"} - + # The result is system dependent # So just test if it runs # The environment variable version was test with test 0.x @@ -1355,8 +1355,8 @@ if {[package vsatisfies [package provide msgcat] 1.7]} { mcutil getsystemlocale set ok ok } -result {ok} - - + + cleanupTests } namespace delete ::msgcat::test diff --git a/tests/namespace.test b/tests/namespace.test index b9e6ead..606139f 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -205,7 +205,7 @@ test namespace-7.8 {Bug ba1419303b4c} -setup { namespace delete ns1 } } -body { - # No segmentation fault given --enable-symbols=mem. + # No segmentation fault given --enable-symbols=mem. namespace delete ns1 } -result {} diff --git a/tests/obj.test b/tests/obj.test index e40ebeb..87c8d08 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -20,8 +20,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} { catch [list package require -exact Tcltest [info patchlevel]] testConstraint testobj [llength [info commands testobj]] -testConstraint longIs32bit [expr {int(0x80000000) < 0}] -testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj { set r 1 @@ -548,34 +548,34 @@ test obj-32.1 {freeing very large object trees} { unset x } {} -test obj-33.1 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +test obj-33.1 {integer overflow on input} {longIs32bit wideIs64bit} { set x 0x8000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {1 2147483648} -test obj-33.2 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +test obj-33.2 {integer overflow on input} {longIs32bit wideIs64bit} { set x 0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 4294967295} test obj-33.3 {integer overflow on input} { set x 0x10000; append x 0000 list [string is integer $x] [expr { wide($x) }] -} {0 4294967296} -test obj-33.4 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +} {1 4294967296} +test obj-33.4 {integer overflow on input} {longIs32bit wideIs64bit} { set x -0x8000; append x 0000 list [string is integer $x] [expr { wide($x) }] } {1 -2147483648} -test obj-33.5 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +test obj-33.5 {integer overflow on input} {longIs32bit wideIs64bit} { set x -0x8000; append x 0001 list [string is integer $x] [expr { wide($x) }] } {1 -2147483649} -test obj-33.6 {integer overflow on input} {longIs32bit wideBiggerThanInt} { +test obj-33.6 {integer overflow on input} {longIs32bit wideIs64bit} { set x -0xffff; append x ffff list [string is integer $x] [expr { wide($x) }] } {1 -4294967295} test obj-33.7 {integer overflow on input} { set x -0x10000; append x 0000 list [string is integer $x] [expr { wide($x) }] -} {0 -4294967296} +} {1 -4294967296} test obj-34.1 {mp_iseven} testobj { set result "" diff --git a/tests/oo.test b/tests/oo.test index 9a22438..4e50904 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -13,13 +13,11 @@ if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* } - # The foundational objects oo::object and oo::class are sensitive to reference # counting errors and are deallocated only when an interp is deleted, so in # this test suite, interp creation and interp deletion are often used in # leaktests in order to leverage this sensitivity. - testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { proc getbytes {} { @@ -340,10 +338,10 @@ test oo-1.21 {basic test of OO functionality: default relations} -setup { lappend x [info object class ::oo::$initial] } return $x - }] {lsort $x} + }] {lsort [lmap y $x {if {[string match *::delegate $y]} continue; set y}]} } -cleanup { interp delete $fresh -} -result {{} {::oo::Slot ::oo::class ::oo::object} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} +} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class} test oo-2.1 {basic test of OO functionality: constructor} -setup { # This is a bit complex because it needs to run in a sub-interp as @@ -2153,7 +2151,7 @@ test oo-15.13.1 { } -cleanup { Cls destroy Cls2 destroy -} -result done +} -result done test oo-15.13.2 {OO: object cloning with target NS} -setup { oo::class create Super oo::class create Cls {superclass Super} @@ -3838,6 +3836,11 @@ proc SampleSlotSetup script { lappend ops [info level] Set $lst return } + method Resolve {lst} { + variable ops + lappend ops [info level] Resolve $lst + return $lst + } } } append script0 \n$script @@ -3872,7 +3875,7 @@ test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}} +}] -result {0 {} {a b c g h i} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {a b c g h i}}} test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { @@ -3880,7 +3883,7 @@ test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {d e f} {1 Set {d e f}}} +}] -result {0 {} {d e f} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f}}} test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { @@ -3888,7 +3891,23 @@ test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup { [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} -}] -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}} +}] -result {0 {} {} {d e f g h i} {1 Resolve d 1 Resolve e 1 Resolve f 1 Set {d e f} 1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {d e f g h i}}} +test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { + SampleSlot create sampleSlot +}] -body { + list [info level] [sampleSlot -prepend g h i] \ + [sampleSlot contents] [sampleSlot ops] +} -cleanup [SampleSlotCleanup { + rename sampleSlot {} +}] -result {0 {} {g h i a b c} {1 Resolve g 1 Resolve h 1 Resolve i 1 Get 1 Set {g h i a b c}}} +test oo-32.6 {TIP 516: slots - class test} -setup [SampleSlotSetup { + SampleSlot create sampleSlot +}] -body { + list [info level] [sampleSlot -remove c a] \ + [sampleSlot contents] [sampleSlot ops] +} -cleanup [SampleSlotCleanup { + rename sampleSlot {} +}] -result {0 {} b {1 Resolve c 1 Resolve a 1 Get 1 Set b}} test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] @@ -3911,7 +3930,7 @@ test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { list [$s destroy; $s unknown] [$s contents] [$s ops] } -cleanup [SampleSlotCleanup { rename $s {} -}] -result {{} unknown {1 Set destroy 1 Set unknown}} +}] -result {{} unknown {1 Resolve destroy 1 Set destroy 1 Resolve unknown 1 Set unknown}} test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup { set s [SampleSlot new] }] -body { @@ -3920,7 +3939,7 @@ test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup { } -returnCodes error -cleanup [SampleSlotCleanup { rename $s {} }] -result \ - {unknown method "-grill": must be -append, -clear, -set, contents or ops} + {unknown method "-grill": must be -append, -clear, -prepend, -remove, -set, contents or ops} test oo-34.1 {TIP 380: slots - presence} -setup { set obj [oo::object new] @@ -3950,25 +3969,68 @@ proc getMethods obj { } test oo-34.3 {TIP 380: slots - presence} { getMethods oo::define::filter -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} test oo-34.4 {TIP 380: slots - presence} { getMethods oo::define::mixin -} {{-append -clear -set} {--default-operation Get Set}} +} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.5 {TIP 380: slots - presence} { getMethods oo::define::superclass -} {{-append -clear -set} {--default-operation Get Set}} +} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.6 {TIP 380: slots - presence} { getMethods oo::define::variable -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} test oo-34.7 {TIP 380: slots - presence} { getMethods oo::objdefine::filter -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} test oo-34.8 {TIP 380: slots - presence} { getMethods oo::objdefine::mixin -} {{-append -clear -set} {--default-operation Get Set}} +} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}} test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable -} {{-append -clear -set} {Get Set}} +} {{-append -clear -prepend -remove -set} {Get Set}} +test oo-34.10 {TIP 516: slots - resolution} -setup { + oo::class create parent + set result {} + oo::class create 516a { superclass parent } + oo::class create 516b { superclass parent } + oo::class create 516c { superclass parent } + namespace eval 516test { + oo::class create 516a { superclass parent } + oo::class create 516b { superclass parent } + oo::class create 516c { superclass parent } + } +} -body { + # Must find the right classes when making the mixin + namespace eval 516test { + oo::define 516a { + mixin 516b 516c + } + } + lappend result [info class mixin 516test::516a] + # Must not remove class with just simple name match + oo::define 516test::516a { + mixin -remove 516b + } + lappend result [info class mixin 516test::516a] + # Must remove class with resolved name match + oo::define 516test::516a { + mixin -remove 516test::516c + } + lappend result [info class mixin 516test::516a] + # Must remove class with resolved name match even after renaming, but only + # with the renamed name; it is a slot of classes, not strings! + rename 516test::516b 516test::516d + oo::define 516test::516a { + mixin -remove 516test::516b + } + lappend result [info class mixin 516test::516a] + oo::define 516test::516a { + mixin -remove 516test::516d + } + lappend result [info class mixin 516test::516a] +} -cleanup { + parent destroy +} -result {{::516test::516b ::516test::516c} {::516test::516b ::516test::516c} ::516test::516b ::516test::516d {}} test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { oo::class create fruit { @@ -4845,6 +4907,75 @@ test oo-40.3 {TIP 500: private and unexport} -setup { } -cleanup { cls destroy } -result {{} {} foo {} foo {}} + +test oo-41.1 {TIP 478: myclass command, including class morphing} -setup { + oo::class create parent + set result {} +} -body { + oo::class create cls1 { + superclass parent + self method count {} { + my variable c + incr c + } + method act {} { + myclass count + } + } + cls1 create x + lappend result [x act] [x act] + cls1 create y + lappend result [y act] [y act] [x act] + oo::class create cls2 { + superclass cls1 + self method count {} { + my variable d + expr {1.0 * [incr d]} + } + } + oo::objdefine x {class cls2} + lappend result [x act] [y act] [x act] [y act] +} -cleanup { + parent destroy +} -result {1 2 3 4 5 1.0 6 2.0 7} +test oo-41.2 {TIP 478: myclass command cleanup} -setup { + oo::class create parent + set result {} +} -body { + oo::class create cls1 { + superclass parent + self method hi {} { + return "this is [self]" + } + method hi {} { + return "this is [self]" + } + } + cls1 create x + rename [info object namespace x]::my foo + rename [info object namespace x]::myclass bar + lappend result [cls1 hi] [x hi] [foo hi] [bar hi] + x destroy + lappend result [catch {foo hi}] [catch {bar hi}] +} -cleanup { + parent destroy +} -result {{this is ::cls1} {this is ::x} {this is ::x} {this is ::cls1} 1 1} +test oo-41.3 {TIP 478: myclass command calls unexported methods, via forward} -setup { + oo::class create parent + set result {} +} -body { + oo::class create cls1 { + superclass parent + self method Hi {} { + return "this is [self]" + } + forward poke myclass Hi + } + cls1 create x + lappend result [catch {cls1 Hi}] [x poke] +} -cleanup { + parent destroy +} -result {1 {this is ::cls1}} cleanupTests return diff --git a/tests/ooUtil.test b/tests/ooUtil.test new file mode 100644 index 0000000..ff7093f --- /dev/null +++ b/tests/ooUtil.test @@ -0,0 +1,563 @@ +# This file contains a collection of tests for functionality originally +# sourced from the ooutil package in Tcllib. Sourcing this file into Tcl runs +# the tests and generates output for errors. No output means no errors were +# found. +# +# Copyright (c) 2014-2016 Andreas Kupries +# Copyright (c) 2018 Donal K. Fellows +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require TclOO 1.0.3 +package require tcltest 2 +if {"::tcltest" in [namespace children]} { + namespace import -force ::tcltest::* +} + +test ooUtil-1.1 {TIP 478: classmethod} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + Table find foo bar +} -cleanup { + parent destroy +} -result {::Table called with arguments: foo bar} +test ooUtil-1.2 {TIP 478: classmethod in namespace} -setup { + namespace eval ::testns {} +} -body { + namespace eval ::testns { + oo::class create ActiveRecord { + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + } + testns::Table find foo bar +} -cleanup { + namespace delete ::testns +} -result {::testns::Table called with arguments: foo bar} +test ooUtil-1.3 {TIP 478: classmethod must not interfere with constructor signatures} -setup { + oo::class create parent +} -body { + oo::class create TestClass { + superclass oo::class parent + self method create {name ignore body} { + next $name $body + } + } + TestClass create okay {} {} +} -cleanup { + parent destroy +} -result {::okay} +test ooUtil-1.4 {TIP 478: classmethod with several inheritance levels} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + oo::class create SubTable { + superclass Table + } + SubTable find foo bar +} -cleanup { + parent destroy +} -result {::SubTable called with arguments: foo bar} +test ooUtil-1.5 {TIP 478: classmethod and instances} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + set t [Table new] + $t find 1 2 3 +} -cleanup { + parent destroy +} -result {::Table called with arguments: 1 2 3} +test ooUtil-1.6 {TIP 478: classmethod and instances} -setup { + oo::class create parent +} -body { + oo::class create ActiveRecord { + superclass parent + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + unexport find + } + set t [Table new] + $t find 1 2 3 +} -returnCodes error -cleanup { + parent destroy +} -match glob -result {unknown method "find": must be *} +test ooUtil-1.7 {} -setup { + oo::class create parent +} -body { + oo::class create Foo { + superclass parent + classmethod bar {} { + puts "This is in the class; self is [self]" + my meee + } + classmethod meee {} { + puts "This is meee" + } + } + oo::class create Grill { + superclass Foo + classmethod meee {} { + puts "This is meee 2" + } + } + list [Foo bar] [Grill bar] [[Foo new] bar] [[Grill new] bar] +} -cleanup { + parent destroy +} -result {{} {} {} {}} -output "This is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\nThis is in the class; self is ::Foo\nThis is meee\nThis is in the class; self is ::Grill\nThis is meee 2\n" +# Two tests to confirm that we correctly initialise the scripted part of TclOO +# in child interpreters. This is slightly tricky at the implementation level +# because we cannot count on either [source] or [open] being available. +test ooUtil-1.8 {TIP 478: classmethod in child interp} -setup { + set childinterp [interp create] +} -body { + $childinterp eval { + oo::class create ActiveRecord { + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + # This is confirming that this is not the master interpreter + list [Table find foo bar] [info globals childinterp] + } +} -cleanup { + interp delete $childinterp +} -result {{::Table called with arguments: foo bar} {}} +test ooUtil-1.9 {TIP 478: classmethod in safe child interp} -setup { + set safeinterp [interp create -safe] +} -body { + $safeinterp eval { + oo::class create ActiveRecord { + classmethod find args { + return "[self] called with arguments: $args" + } + } + oo::class create Table { + superclass ActiveRecord + } + # This is confirming that this is a (basic) safe interpreter + list [Table find foo bar] [info commands source] + } +} -cleanup { + interp delete $safeinterp +} -result {{::Table called with arguments: foo bar} {}} + +test ooUtil-2.1 {TIP 478: callback generation} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {} { return ok,[self] } + method makeCall {} { + return [callback CallMe] + } + } + c create ::context + set cb [context makeCall] + {*}$cb +} -cleanup { + parent destroy +} -result {ok,::context} +test ooUtil-2.2 {TIP 478: callback generation} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {a b c} { return ok,[self],$a,$b,$c } + method makeCall {b} { + return [callback CallMe 123 $b] + } + } + c create ::context + set cb [context makeCall "a b c"] + {*}$cb PQR +} -cleanup { + parent destroy +} -result {ok,::context,123,a b c,PQR} +test ooUtil-2.3 {TIP 478: callback generation, alternate name} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {} { return ok,[self] } + method makeCall {} { + return [mymethod CallMe] + } + } + c create ::context + set cb [context makeCall] + {*}$cb +} -cleanup { + parent destroy +} -result {ok,::context} +test ooUtil-2.4 {TIP 478: callback generation, alternate name} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method CallMe {a b c} { return ok,[self],$a,$b,$c } + method makeCall {b} { + return [mymethod CallMe 123 $b] + } + } + c create ::context + set cb [context makeCall "a b c"] + {*}$cb PQR +} -cleanup { + parent destroy +} -result {ok,::context,123,a b c,PQR} +test ooUtil-2.5 {TIP 478: callbacks and method lifetime} -setup { + oo::class create parent +} -body { + oo::class create c { + superclass parent + method makeCall {b} { + return [callback CallMe 123 $b] + } + } + c create ::context + set cb [context makeCall "a b c"] + set result [list [catch {{*}$cb PQR} msg] $msg] + oo::objdefine context { + method CallMe {a b c} { return ok,[self],$a,$b,$c } + } + lappend result [{*}$cb PQR] +} -cleanup { + parent destroy +} -result {1 {unknown method "CallMe": must be <cloned>, destroy, eval, makeCall, unknown, variable or varname} {ok,::context,123,a b c,PQR}} +test ooUtil-2.6 {TIP 478: callback use case} -setup { + oo::class create parent + unset -nocomplain x +} -body { + oo::class create c { + superclass parent + variable count + constructor {var} { + set count 0 + upvar 1 $var v + trace add variable v write [callback TraceCallback] + } + method count {} {return $count} + method TraceCallback {name1 name2 op} { + incr count + } + } + set o [c new x] + for {set x 0} {$x < 5} {incr x} {} + $o count +} -cleanup { + unset -nocomplain x + parent destroy +} -result 6 + +test ooUtil-3.1 {TIP 478: class initialisation} -setup { + oo::class create parent + catch {rename ::foobar-3.1 {}} +} -body { + oo::class create ::cls { + superclass parent + initialise { + proc foobar-3.1 {} {return ok} + } + method calls {} { + list [catch foobar-3.1 msg] $msg \ + [namespace eval [info object namespace [self class]] foobar-3.1] + } + } + [cls new] calls +} -cleanup { + parent destroy +} -result {1 {invalid command name "foobar-3.1"} ok} +test ooUtil-3.2 {TIP 478: class variables} -setup { + oo::class create parent + catch {rename ::foobar-3.1 {}} +} -body { + oo::class create ::cls { + superclass parent + initialise { + variable x 123 + } + method call {} { + classvariable x + incr x + } + } + cls create a + cls create b + cls create c + list [a call] [b call] [c call] [a call] [b call] [c call] +} -cleanup { + parent destroy +} -result {124 125 126 127 128 129} +test ooUtil-3.3 {TIP 478: class initialisation} -setup { + oo::class create parent + catch {rename ::foobar-3.3 {}} +} -body { + oo::class create ::cls { + superclass parent + initialize { + proc foobar-3.3 {} {return ok} + } + method calls {} { + list [catch foobar-3.3 msg] $msg \ + [namespace eval [info object namespace [self class]] foobar-3.3] + } + } + [cls new] calls +} -cleanup { + parent destroy +} -result {1 {invalid command name "foobar-3.3"} ok} +test ooUtil-3.4 {TIP 478: class initialisation} -setup { + oo::class create parent + catch {rename ::appendToResultVar {}} + proc ::appendToResultVar args { + lappend ::result {*}$args + } + set result {} +} -body { + trace add execution oo::define::initialise enter appendToResultVar + oo::class create ::cls { + superclass parent + initialize {proc xyzzy {} {}} + } + return $result +} -cleanup { + catch { + trace remove execution oo::define::initialise enter appendToResultVar + } + rename ::appendToResultVar {} + parent destroy +} -result {{initialize {proc xyzzy {} {}}} enter} +test ooUtil-3.5 {TIP 478: class initialisation} -body { + oo::define oo::object { + ::list [::namespace which initialise] [::namespace which initialize] \ + [::namespace origin initialise] [::namespace origin initialize] + } +} -result {::oo::define::initialise ::oo::define::initialize ::oo::define::initialise ::oo::define::initialise} + +test ooUtil-4.1 {TIP 478: singleton} -setup { + oo::class create parent +} -body { + oo::singleton create xyz { + superclass parent + } + set x [xyz new] + set y [xyz new] + set z [xyz new] + set code [catch {$x destroy} msg] + set p [xyz new] + lappend code [catch {rename $x ""}] + set q [xyz new] + string map [list $x ONE $q TWO] [list {*}$code $x $y $z $p $q [xyz new]] +} -cleanup { + parent destroy +} -result {1 0 ONE ONE ONE ONE TWO TWO} +test ooUtil-4.2 {TIP 478: singleton errors} -setup { + oo::class create parent +} -body { + oo::singleton create xyz { + superclass parent + } + [xyz new] destroy +} -returnCodes error -cleanup { + parent destroy +} -result {may not destroy a singleton object} +test ooUtil-4.3 {TIP 478: singleton errors} -setup { + oo::class create parent +} -body { + oo::singleton create xyz { + superclass parent + } + oo::copy [xyz new] +} -returnCodes error -cleanup { + parent destroy +} -result {may not clone a singleton object} + + +test ooUtil-5.1 {TIP 478: abstract} -setup { + oo::class create parent +} -body { + oo::abstract create xyz { + superclass parent + method foo {} {return 123} + } + oo::class create pqr { + superclass xyz + method bar {} {return 456} + } + set codes [list [catch {xyz new}] [catch {xyz create x}] [catch {xyz createWithNamespace x y}]] + set x [pqr new] + set y [pqr create ::y] + lappend codes [$x foo] [$x bar] $y +} -cleanup { + parent destroy +} -result {1 1 1 123 456 ::y} + +test ooUtil-6.1 {TIP 478: classvarable} -setup { + oo::class create parent +} -body { + oo::class create xyz { + superclass parent + initialise { + variable x 1 y 2 + } + method a {} { + classvariable x + incr x + } + method b {} { + classvariable y + incr y + } + method c {} { + classvariable x y + list $x $y + } + } + set p [xyz new] + set q [xyz new] + set result [list [$p c] [$q c]] + $p a + $q b + lappend result [[xyz new] c] +} -cleanup { + parent destroy +} -result {{1 2} {1 2} {2 3}} +test ooUtil-6.2 {TIP 478: classvarable error case} -setup { + oo::class create parent +} -body { + oo::class create xyz { + superclass parent + method a {} { + classvariable x(1) + incr x(1) + } + } + set p [xyz new] + set q [xyz new] + list [$p a] [$q a] +} -returnCodes error -cleanup { + parent destroy +} -result {bad variable name "x(1)": can't create a scalar variable that looks like an array element} +test ooUtil-6.3 {TIP 478: classvarable error case} -setup { + oo::class create parent +} -body { + oo::class create xyz { + superclass parent + method a {} { + classvariable ::x + incr x + } + } + set p [xyz new] + set q [xyz new] + list [$p a] [$q a] +} -returnCodes error -cleanup { + parent destroy +} -result {bad variable name "::x": can't create a local variable with a namespace separator in it} + +test ooUtil-7.1 {TIP 478: link calling pattern} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + method foo {} {return "in foo of [self]"} + method Bar {} {return "in bar of [self]"} + method Grill {} {return "in grill of [self]"} + export eval + constructor {} { + link foo + link {bar Bar} {grill Grill} + } + } + cls create o + o eval {list [foo] [bar] [grill]} +} -cleanup { + parent destroy +} -result {{in foo of ::o} {in bar of ::o} {in grill of ::o}} +test ooUtil-7.2 {TIP 478: link removed when [my] disappears} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + method foo {} {return "in foo of [self]"} + constructor {cmd} { + link [list ::$cmd foo] + } + } + cls create o pqr + list [o foo] [pqr] [rename [info object namespace o]::my {}] [catch pqr msg] $msg +} -cleanup { + parent destroy +} -result {{in foo of ::o} {in foo of ::o} {} 1 {invalid command name "pqr"}} + +# Tests that verify issues detected with the tcllib version of the code +test ooUtil-tcllib-ticket-b3577ed586 {test scoping of delegation in oo::class.Delegate } -setup { + oo::class create animal {} + namespace eval ::ooutiltest { + oo::class create pet { superclass animal } + } +} -body { + namespace eval ::ooutiltest { + oo::class create dog { superclass pet } + } +} -cleanup { + namespace delete ooutiltest + rename animal {} +} -result {::ooutiltest::dog} +test ooUtil-tcllib-ticket-fe7a0e0a3a {classmethod must not interfere with constructor signatures} -setup { + oo::class create TestClass { + superclass oo::class + self method create {name ignore body} { + next $name $body + } + } +} -body { + TestClass create okay {} {} +} -cleanup { + rename TestClass {} +} -result {::okay} + +cleanupTests +return + +# Local Variables: +# fill-column: 78 +# mode: tcl +# End: diff --git a/tests/package.test b/tests/package.test index 2843701..2dca06b 100644 --- a/tests/package.test +++ b/tests/package.test @@ -23,7 +23,7 @@ catch [list package require -exact Tcltest [info patchlevel]] # Do all this in a slave interp to avoid garbaging the package list set i [interp create] tcltest::loadIntoSlaveInterpreter $i {*}$argv -load {} Tcltest $i +catch [list load {} Tcltest $i] interp eval $i { namespace import -force ::tcltest::* #package forget {*}[package names] @@ -630,13 +630,13 @@ test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup { } -body { coroutine coro1 apply {{} { package ifneeded t 2.1 { - yield + yield package provide t 2.1 } package require t 2.1 }} list [catch {coro1} msg] $msg -} -match glob -result {0 2.1} +} -match glob -result {0 2.1} test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body { diff --git a/tests/pkgIndex.tcl b/tests/pkgIndex.tcl new file mode 100644 index 0000000..854b943 --- /dev/null +++ b/tests/pkgIndex.tcl @@ -0,0 +1,6 @@ +#! /usr/bin/env tclsh + +package ifneeded tcltests 0.1 " + source [list $dir/tcltests.tcl] + package provide tcltests 0.1 +" diff --git a/tests/platform.test b/tests/platform.test index 8a68351..53d534e 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -22,8 +22,10 @@ namespace eval ::tcl::test::platform { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] +package require tcltests testConstraint testCPUID [llength [info commands testcpuid]] +testConstraint testlongsize [llength [info commands testlongsize]] test platform-1.0 {tcl_platform(engine)} { set tcl_platform(engine) @@ -38,16 +40,9 @@ test platform-1.1 {TclpSetVariables: tcl_platform} { set result } {byteOrder engine machine os osVersion pathSeparator platform pointerSize user wordSize} -# Test assumes twos-complement arithmetic, which is true of virtually -# everything these days. Note that this does *not* use wide(), and -# this is intentional since that could make Tcl's numbers wider than -# the machine-integer on some platforms... -test platform-2.1 {tcl_platform(wordSize) indicates size of native word} { - set result [expr {int(1 << (8 * $tcl_platform(wordSize) - 1))}] - # Result must be the largest bit in a machine word, which this checks - # without assuming how wide the word really is - list [expr {$result < 0}] [expr {$result ^ int($result - 1)}] -} {1 -1} +test platform-2.1 {tcl_platform(wordSize) indicates size of native word} testlongsize { + expr {$tcl_platform(wordSize) == [testlongsize]} +} {1} # On Windows/UNIX, test that the CPU ID works @@ -67,7 +62,10 @@ test platform-3.1 {CPU ID on Windows/UNIX} \ # format of string it produces consists of two non-empty words separated by a # hyphen. package require platform -test platform-4.1 {format of platform::identify result} -match regexp -body { +test platform-4.1 {format of platform::identify result} -constraints notValgrind -match regexp -body { + # [identify] may attempt to [exec] dpkg-architecture, which may not exist, + # in which case fork will not be followed by exec, and valgrind will issue + # "still reachable" reports. platform::identify } -result {^([^-]+-)+[^-]+$} test platform-4.2 {format of platform::generic result} -match regexp -body { diff --git a/tests/proc.test b/tests/proc.test index bae5e15..1893d0f 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -110,6 +110,14 @@ test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple name proc p {b:a b::a} { } } -returnCodes error -result {formal parameter "b::a" is not a simple name} +test proc-1.9 {Tcl_ProcObjCmd, arguments via canonical list (string-representation bug [631b4c45df])} -body { + set v 2 + binary scan AB cc a b + proc p [list [list a $a] [list b $b] [list v [expr {$v + 2}]]] {expr {$a + $b + $v}} + p +} -result [expr {65+66+4}] -cleanup { + rename p {} +} test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -383,6 +391,14 @@ test proc-7.4 {Proc struct outlives its interp: Bug 3532959} { interp delete slave unset lambda } {} + +test proc-7.5 {[631b4c45df] Crash in argument processing} { + binary scan A c val + proc foo [list [list from $val]] {} + rename foo {} + unset -nocomplain val +} {} + # cleanup catch {rename p ""} diff --git a/tests/process.test b/tests/process.test index b88c50a..5aa8354 100644 --- a/tests/process.test +++ b/tests/process.test @@ -63,7 +63,7 @@ test process-4.1 {exec one child} -body { set statuses [tcl::process status -wait] set status [lindex [tcl::process status $pid] 1] expr { - [llength $list] eq 1 + [llength $list] eq 1 && [lindex $list 0] eq $pid && [dict size $statuses] eq 1 && [dict get $statuses $pid] eq $status @@ -139,7 +139,7 @@ test process-5.1 {exec one child} -body { set statuses [tcl::process status -wait] set status [lindex [tcl::process status $pid] 1] expr { - [llength $list] eq 1 + [llength $list] eq 1 && [lindex $list 0] eq $pid && [dict size $statuses] eq 1 && [dict get $statuses $pid] eq $status diff --git a/tests/safe.test b/tests/safe.test index df60de6..356e176 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -92,7 +92,7 @@ test safe-3.2 {calling safe::interpCreate on trusted interp} -setup { lsort [a aliases] } -cleanup { safe::interpDelete a -} -result {::tcl::file::atime ::tcl::file::attributes ::tcl::file::copy ::tcl::file::delete ::tcl::file::dirname ::tcl::file::executable ::tcl::file::exists ::tcl::file::extension ::tcl::file::isdirectory ::tcl::file::isfile ::tcl::file::link ::tcl::file::lstat ::tcl::file::mkdir ::tcl::file::mtime ::tcl::file::nativename ::tcl::file::normalize ::tcl::file::owned ::tcl::file::readable ::tcl::file::readlink ::tcl::file::rename ::tcl::file::rootname ::tcl::file::size ::tcl::file::stat ::tcl::file::tail ::tcl::file::tempfile ::tcl::file::type ::tcl::file::volumes ::tcl::file::writable ::tcl::info::nameofexecutable clock encoding exit glob load source} +} -result {::tcl::encoding::system ::tcl::file::dirname ::tcl::file::extension ::tcl::file::rootname ::tcl::file::tail ::tcl::info::nameofexecutable clock encoding exit file glob load source} test safe-3.3 {calling safe::interpCreate on trusted interp} -setup { catch {safe::interpDelete a} } -body { @@ -308,14 +308,10 @@ test safe-8.7 {safe source control on file} -setup { unset log safe::interpDelete $i } -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] xxxxxxxxxxx.tcl]:no such file or directory"]] -test safe-8.8 {safe source forbids -rsrc} -setup { - catch {safe::interpDelete $i} - safe::interpCreate $i -} -body { - $i eval {source -rsrc Init} -} -returnCodes error -cleanup { - safe::interpDelete $i -} -result {wrong # args: should be "source ?-encoding E? fileName"} +test safe-8.8 {safe source forbids -rsrc} emptyTest { + # Disabled this test. It was only useful for long unsupported + # Mac OS 9 systems. [Bug 860a9f1945] +} {} test safe-8.9 {safe source and return} -setup { set returnScript [makeFile {return "ok"} return.tcl] catch {safe::interpDelete $i} @@ -468,14 +464,14 @@ test safe-11.1 {testing safe encoding} -setup { interp eval $i encoding } -returnCodes error -cleanup { safe::interpDelete $i -} -result {wrong # args: should be "encoding option ?arg ...?"} +} -result {wrong # args: should be "encoding subcommand ?arg ...?"} test safe-11.1a {testing safe encoding} -setup { set i [safe::interpCreate] } -body { interp eval $i encoding foobar } -returnCodes error -cleanup { safe::interpDelete $i -} -match glob -result {bad option "foobar": must be *} +} -match glob -result {unknown or ambiguous subcommand "foobar": must be *} test safe-11.2 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -530,8 +526,6 @@ test safe-11.7.1 {testing safe encoding} -setup { while executing "encoding convertfrom" invoked from within -"::interp invokehidden interp* encoding convertfrom" - invoked from within "encoding convertfrom" invoked from within "interp eval $i encoding convertfrom"} @@ -554,8 +548,6 @@ test safe-11.8.1 {testing safe encoding} -setup { while executing "encoding convertto" invoked from within -"::interp invokehidden interp* encoding convertto" - invoked from within "encoding convertto" invoked from within "interp eval $i encoding convertto"} @@ -769,7 +761,7 @@ test safe-15.1 {safe file ensemble does not surprise code} -setup { unset -nocomplain msg interp delete $i } -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}} -test safe-15.1.1 {safe file ensemble does not surprise code} -setup { +test safe-15.2 {safe file ensemble does not surprise code} -setup { set i [interp create -safe] } -body { set result [expr {"file" in [interp hidden $i]}] diff --git a/tests/scan.test b/tests/scan.test index 1f32b9f..b488f68 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -19,11 +19,8 @@ if {"::tcltest" ni [namespace children]} { # procedure that returns the range of integers proc int_range {} { - for { set MIN_INT 1 } { int($MIN_INT) > 0 } {} { - set MIN_INT [expr { $MIN_INT << 1 }] - } - set MIN_INT [expr {int($MIN_INT)}] - set MAX_INT [expr { ~ $MIN_INT }] + set MAX_INT [expr {[format %u -2]/2}] + set MIN_INT [expr { ~ $MAX_INT }] return [list $MIN_INT $MAX_INT] } @@ -85,8 +82,7 @@ proc testIEEE {} { } testConstraint ieeeFloatingPoint [testIEEE] -testConstraint wideIs64bit \ - [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] +testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}] test scan-1.1 {BuildCharSet, CharInSet} { list [scan foo {%[^o]} x] $x diff --git a/tests/set-old.test b/tests/set-old.test index b2e7aa6..ea5155b 100644 --- a/tests/set-old.test +++ b/tests/set-old.test @@ -340,7 +340,7 @@ test set-old-8.6 {array command} { catch {unset a} set a(22) 3 list [catch {array gorp a} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be anymore, donesearch, exists, for, get, names, nextelement, set, size, startsearch, statistics, or unset}} +} {1 {unknown or ambiguous subcommand "gorp": must be anymore, default, donesearch, exists, for, get, names, nextelement, set, size, startsearch, statistics, or unset}} test set-old-8.7 {array command, anymore option} { catch {unset a} list [catch {array anymore a x} msg] $msg @@ -700,7 +700,7 @@ test set-old-9.1 {ids for array enumeration} { catch {unset a} set a(a) 1 list [array star a] [array star a] [array done a s-1-a; array star a] \ - [array done a s-2-a; array d a s-3-a; array start a] + [array done a s-2-a; array do a s-3-a; array start a] } {s-1-a s-2-a s-3-a s-1-a} test set-old-9.2 {array enumeration} { catch {unset a} diff --git a/tests/string.test b/tests/string.test index 0cbafae..a0eaac8 100644 --- a/tests/string.test +++ b/tests/string.test @@ -280,7 +280,7 @@ test string-3.17.$noComp {string equal, unicode} { } 1 test string-3.18.$noComp {string equal, unicode} { run {string equal \334 \u00fc} -} 0 +} 0 test string-3.19.$noComp {string equal, unicode} { run {string equal \334\334\334\374\374 \334\334\334\334\334} } 0 @@ -307,7 +307,7 @@ test string-3.24.$noComp {string equal -nocase with length} { } 1 test string-3.25.$noComp {string equal -nocase with length} { run {string equal -nocase -length 3 abcde Abxyz} -} 0 +} 0 test string-3.26.$noComp {string equal -nocase with length <= 0} { run {string equal -nocase -length -1 abcde AbCdEf} } 0 @@ -674,9 +674,9 @@ test string-6.53.$noComp {string is integer, true with whitespace} { test string-6.54.$noComp {string is integer, false} { list [run {string is integer -fail var 123abc}] $var } {0 3} -test string-6.55.$noComp {string is integer, false on overflow} { - list [run {string is integer -fail var +[largest_int]0}] $var -} {0 -1} +test string-6.55.$noComp {string is integer, no overflow possible} { + run {string is integer +[largest_int]0} +} 1 test string-6.56.$noComp {string is integer, false} { list [run {string is integer -fail var [expr double(1)]}] $var } {0 1} @@ -807,22 +807,22 @@ test string-6.91.$noComp {string is double, bad doubles} { } return $result } {1 1 0 0 0 1 0 0} -test string-6.92.$noComp {string is integer, 32-bit overflow} { +test string-6.92.$noComp {string is integer, no 64-bit overflow} { # Bug 718878 - set x 0x100000000 - list [run {string is integer -failindex var $x}] $var -} {0 -1} -test string-6.93.$noComp {string is integer, 32-bit overflow} { + set x 0x10000000000000000 + run {string is integer $x} +} 1 +test string-6.93.$noComp {string is integer, no 64-bit overflow} { # Bug 718878 - set x 0x100000000 + set x 0x10000000000000000 append x "" - list [run {string is integer -failindex var $x}] $var -} {0 -1} -test string-6.94.$noComp {string is integer, 32-bit overflow} { + run {string is integer $x} +} 1 +test string-6.94.$noComp {string is integer, no 64-bit overflow} { # Bug 718878 - set x 0x100000000 - list [run {string is integer -failindex var [expr {$x}]}] $var -} {0 -1} + set x 0x10000000000000000 + run {string is integer [expr {$x}]} +} 1 test string-6.95.$noComp {string is wideinteger, true} { run {string is wideinteger +1234567890} } 1 @@ -2306,6 +2306,12 @@ test string-29.15.$noComp {string cat, efficiency} -setup { tcl::unsupported::representation [run {string cat $e $f $e $f [list x]}] } -match glob -result {*no string representation} } +test string-30.1.1.$noComp {[Bug ba921a8d98]: string cat} { + run {string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data]} +} hellohello +test string-30.1.2.$noComp {[Bug ba921a8d98]: inplace cat by subst (compiled to "strcat" instruction)} { + run {set x "[set data [binary format a* hello]][encoding convertto $data][unset data]"} +} hellohello } diff --git a/tests/tailcall.test b/tests/tailcall.test index ce506a7..9174167 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -688,6 +688,26 @@ if {[testConstraint testnrelevels]} { namespace delete testnre } +test tailcall-14.1 {in a deleted namespace} -body { + namespace eval ns { + proc p args { + tailcall [namespace current] $args + } + namespace delete [namespace current] + p + } +} -returnCodes 1 -result {namespace "::ns" not found} + +test tailcall-14.1-bc {{in a deleted namespace} {byte compiled}} -body { + namespace eval ns { + proc p args { + tailcall [namespace current] {*}$args + } + namespace delete [namespace current] + p + } +} -returnCodes 1 -result {namespace "::ns" not found} + # cleanup ::tcltest::cleanupTests diff --git a/tests/tcltest.test b/tests/tcltest.test index 17fa926..1487865 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -908,7 +908,9 @@ removeFile load.tcl # [interpreter] test tcltest-13.1 {interpreter} { + -constraints notValgrind -setup { + #to do: Why is $::tcltest::tcltest being saved and restored here? set old $::tcltest::tcltest set ::tcltest::tcltest tcltest } @@ -920,6 +922,11 @@ test tcltest-13.1 {interpreter} { } -result {tcltest tclsh tclsh} -cleanup { + # writing ::tcltest::tcltest triggers a trace that sets up the stdio + # constraint, which involves a call to [exec] that might fail after + # "fork" and before "exec", in which case the forked process will not + # have a chance to clean itself up before exiting, which causes + # valgrind to issue numerous "still reachable" reports. set ::tcltest::tcltest $old } } diff --git a/tests/tcltests.tcl b/tests/tcltests.tcl new file mode 100644 index 0000000..74d1b40 --- /dev/null +++ b/tests/tcltests.tcl @@ -0,0 +1,11 @@ +#! /usr/bin/env tclsh + +package require tcltest 2.2 +namespace import ::tcltest::* + +testConstraint exec [llength [info commands exec]] +testConstraint fcopy [llength [info commands fcopy]] +testConstraint fileevent [llength [info commands fileevent]] +testConstraint thread [ + expr {0 == [catch {package require Thread 2.7-}]}] +testConstraint notValgrind [expr {![testConstraint valgrind]}] diff --git a/tests/thread.test b/tests/thread.test index cc4c871..2524911 100644 --- a/tests/thread.test +++ b/tests/thread.test @@ -11,25 +11,22 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2.2 +if {"::tcltest" ni [namespace children]} { + package require tcltest 2 namespace import -force ::tcltest::* } +# when thread::release is used, -wait is passed in order allow the thread to +# be fully finalized, which avoids valgrind "still reachable" reports. + ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] +package require tcltests # Some tests require the testthread command -testConstraint testthread [expr {[info commands testthread] != {}}] - -# Some tests require the Thread package - -testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] +testConstraint testthread [expr {[info commands testthread] ne {}}] -# Some tests may not work under valgrind - -testConstraint notValgrind [expr {![testConstraint valgrind]}] set threadSuperKillScript { rename catch "" @@ -72,6 +69,17 @@ proc ThreadError {id info} { set threadSawError($id) true; # signal main thread to exit [vwait]. } +proc threadSuperKill id { + variable threadSuperKillScript + try { + thread::send $id $::threadSuperKillScript + } on error {tres topts} { + if {$tres ne {target thread died}} { + return -options $topts $tres + } + } +} + if {[testConstraint thread]} { thread::errorproc ThreadError } @@ -96,22 +104,22 @@ test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {thread} { test thread-1.4 {Tcl_ThreadObjCmd: thread create } {thread} { set serverthread [thread::create -preserved] set numthreads [llength [thread::names]] - thread::release $serverthread + thread::release -wait $serverthread set numthreads -} {2} +} 2 test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {thread} { thread::create {set x 5} foreach try {0 1 2 4 5 6} { - # Try various ways to yield - update - after 10 - set l [llength [thread::names]] - if {$l == 1} { - break - } + # Try various ways to yield + update + after 10 + set l [llength [thread::names]] + if {$l == 1} { + break + } } set l -} {1} +} 1 test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} { thread::create {{*}{}} update @@ -121,13 +129,13 @@ test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} { test thread-1.13 {Tcl_ThreadObjCmd: send args} {thread} { set serverthread [thread::create -preserved] set five [thread::send $serverthread {set x 5}] - thread::release $serverthread + thread::release -wait $serverthread set five } 5 test thread-1.15 {Tcl_ThreadObjCmd: wait} {thread} { set serverthread [thread::create -preserved {set z 5 ; thread::wait}] set five [thread::send $serverthread {set z}] - thread::release $serverthread + thread::release -wait $serverthread set five } 5 @@ -159,7 +167,7 @@ test thread-3.1 {TclThreadList} {thread} { set l2 [thread::names] set c [string compare [lsort [concat [thread::id] $l1]] [lsort $l2]] foreach t $l1 { - thread::release $t + thread::release -wait $t } list $len $c } {1 0} @@ -887,7 +895,7 @@ test thread-7.24 {cancel: nested catch inside pure bytecode loop} {thread drainE # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::cancel $serverthread] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -929,7 +937,7 @@ test thread-7.25 {cancel: nested catch inside pure inside-command loop} {thread # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::cancel $serverthread] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -1029,7 +1037,7 @@ test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode lo # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::send -async $serverthread {interp cancel}] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -1071,7 +1079,7 @@ test thread-7.29 {cancel: send async cancel nested catch pure inside-command loo # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::send -async $serverthread {interp cancel}] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -1111,7 +1119,7 @@ test thread-7.30 {cancel: send async thread cancel nested catch inside pure byte # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::send -async $serverthread {thread::cancel [thread::id]}] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ @@ -1153,7 +1161,7 @@ test thread-7.31 {cancel: send async thread cancel nested catch pure inside-comm # wait for other thread to signal "ready to cancel" vwait ::threadIdStarted; after 1000 set res [thread::send -async $serverthread {thread::cancel [thread::id]}] - thread::send $serverthread $::threadSuperKillScript + threadSuperKill $serverthread vwait ::threadSawError($serverthread) thread::join $serverthread; drainEventQueue list $res [expr {[info exists ::threadIdStarted] ? \ diff --git a/tests/uplevel.test b/tests/uplevel.test index 737c571..be2268a 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.test @@ -137,27 +137,27 @@ test uplevel-4.15 {level parsing} { test uplevel-4.16 {level parsing} { apply {{} {uplevel #[expr 1] {}}} } {} -test uplevel-4.17 {level parsing} { +test uplevel-4.17 {level parsing} -returnCodes error -body { apply {{} {uplevel -0xffffffff {}}} -} {} -test uplevel-4.18 {level parsing} { +} -result {bad level "-0xffffffff"} +test uplevel-4.18 {level parsing} -returnCodes error -body { apply {{} {uplevel #-0xffffffff {}}} -} {} -test uplevel-4.19 {level parsing} { +} -result {bad level "#-0xffffffff"} +test uplevel-4.19 {level parsing} -returnCodes error -body { apply {{} {uplevel [expr -0xffffffff] {}}} -} {} -test uplevel-4.20 {level parsing} { +} -result {bad level "-4294967295"} +test uplevel-4.20 {level parsing} -returnCodes error -body { apply {{} {uplevel #[expr -0xffffffff] {}}} -} {} +} -result {bad level "#-4294967295"} test uplevel-4.21 {level parsing} -body { apply {{} {uplevel -1 {}}} -} -returnCodes error -result {invalid command name "-1"} +} -returnCodes error -result {bad level "-1"} test uplevel-4.22 {level parsing} -body { apply {{} {uplevel #-1 {}}} } -returnCodes error -result {bad level "#-1"} test uplevel-4.23 {level parsing} -body { apply {{} {uplevel [expr -1] {}}} -} -returnCodes error -result {invalid command name "-1"} +} -returnCodes error -result {bad level "-1"} test uplevel-4.24 {level parsing} -body { apply {{} {uplevel #[expr -1] {}}} } -returnCodes error -result {bad level "#-1"} @@ -175,13 +175,13 @@ test uplevel-4.28 {level parsing} -body { } -returnCodes error -result {bad level "#4294967295"} test uplevel-4.29 {level parsing} -body { apply {{} {uplevel 0.2 {}}} -} -returnCodes error -result {bad level "0.2"} +} -returnCodes error -result {invalid command name "0.2"} test uplevel-4.30 {level parsing} -body { apply {{} {uplevel #0.2 {}}} } -returnCodes error -result {bad level "#0.2"} test uplevel-4.31 {level parsing} -body { apply {{} {uplevel [expr 0.2] {}}} -} -returnCodes error -result {bad level "0.2"} +} -returnCodes error -result {invalid command name "0.2"} test uplevel-4.32 {level parsing} -body { apply {{} {uplevel #[expr 0.2] {}}} } -returnCodes error -result {bad level "#0.2"} @@ -193,7 +193,7 @@ test uplevel-4.34 {level parsing} -body { } -returnCodes error -result {bad level "#.2"} test uplevel-4.35 {level parsing} -body { apply {{} {uplevel [expr .2] {}}} -} -returnCodes error -result {bad level "0.2"} +} -returnCodes error -result {invalid command name "0.2"} test uplevel-4.36 {level parsing} -body { apply {{} {uplevel #[expr .2] {}}} } -returnCodes error -result {bad level "#0.2"} diff --git a/tests/utf.test b/tests/utf.test index 9dd8017..e820359 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -44,6 +44,18 @@ test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring { test utf-1.7 {Tcl_UniCharToUtf: 4 byte sequences} -constraints testbytestring -body { expr {"\U014e4e" eq [testbytestring "\xf0\x94\xb9\x8e"]} } -result 1 +test utf-1.8 {Tcl_UniCharToUtf: 3 byte sequence, upper surrogate} testbytestring { + expr {"\ud842" eq [testbytestring "\xed\xa1\x82"]} +} 1 +test utf-1.9 {Tcl_UniCharToUtf: 3 byte sequence, lower surrogate} testbytestring { + expr {"\udc42" eq [testbytestring "\xed\xb1\x82"]} +} 1 +test utf-1.10 {Tcl_UniCharToUtf: 3 byte sequence, upper surrogate} testbytestring { + expr {[format %c 0xd842] eq [testbytestring "\xed\xa1\x82"]} +} 1 +test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, lower surrogate} testbytestring { + expr {[format %c 0xdc42] eq [testbytestring "\xed\xb1\x82"]} +} 1 test utf-2.1 {Tcl_UtfToUniChar: low ascii} { string length "abc" @@ -146,6 +158,12 @@ test utf-8.3 {Tcl_UniCharAtIndex: index > 0} { test utf-8.4 {Tcl_UniCharAtIndex: index > 0} { string index \u4e4e\u25a\xff\u543 2 } "\uff" +test utf-8.5 {Tcl_UniCharAtIndex: upper surrogate} { + string index \ud842 0 +} "\ud842" +test utf-8.5 {Tcl_UniCharAtIndex: lower surrogate} { + string index \udc42 0 +} "\udc42" test utf-9.1 {Tcl_UtfAtIndex: index = 0} { string range abcd 0 2 @@ -251,6 +269,9 @@ test utf-11.4 {Tcl_UtfToUpper} { test utf-11.5 {Tcl_UtfToUpper Georgian (new in Unicode 11)} { string toupper \u10d0\u1c90 } \u1c90\u1c90 +test utf-11.6 {Tcl_UtfToUpper low/high surrogate)} { + string toupper \udc24\ud824 +} \udc24\ud824 test utf-12.1 {Tcl_UtfToLower} { string tolower {} @@ -267,6 +288,9 @@ test utf-12.4 {Tcl_UtfToLower} { test utf-12.5 {Tcl_UtfToLower Georgian (new in Unicode 11)} { string tolower \u10d0\u1c90 } \u10d0\u10d0 +test utf-12.6 {Tcl_UtfToUpper low/high surrogate)} { + string tolower \udc24\ud824 +} \udc24\ud824 test utf-13.1 {Tcl_UtfToTitle} { string totitle {} @@ -286,6 +310,9 @@ test utf-13.5 {Tcl_UtfToTitle Georgian (new in Unicode 11)} { test utf-13.6 {Tcl_UtfToTitle Georgian (new in Unicode 11)} { string totitle \u1c90\u10d0 } \u1c90\u10d0 +test utf-13.7 {Tcl_UtfToTitle low/high surrogate)} { + string totitle \udc24\ud824 +} \udc24\ud824 test utf-14.1 {Tcl_UtfNcasecmp} { string compare -nocase a b diff --git a/tests/util.test b/tests/util.test index 35fc642..34113c0 100644 --- a/tests/util.test +++ b/tests/util.test @@ -689,13 +689,13 @@ test util-9.31.1 {TclGetIntForIndex} -body { } -returnCodes error -match glob -result * test util-9.32 {TclGetIntForIndex} -body { string index a 0x1FFFFFFFF+0 -} -returnCodes error -match glob -result * +} -result {} test util-9.33 {TclGetIntForIndex} -body { string index a 100000000000+0 -} -returnCodes error -match glob -result * +} -result {} test util-9.33.1 {TclGetIntForIndex} -body { string index a 0d100000000000+0 -} -returnCodes error -match glob -result * +} -result {} test util-9.34 {TclGetIntForIndex} -body { string index a 1.0 } -returnCodes error -match glob -result * @@ -728,7 +728,13 @@ test util-9.43 {TclGetIntForIndex} -body { } -returnCodes error -match glob -result * test util-9.44 {TclGetIntForIndex} -body { string index a 0+1000000000000 -} -returnCodes error -match glob -result * +} -result {} +test util-9.45 {TclGetIntForIndex} { + string index abcd end+2305843009213693950 +} {} +test util-9.46 {TclGetIntForIndex} { + string index abcd end+4294967294 +} {} test util-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x0000000000000000 diff --git a/tests/var.test b/tests/var.test index 7b7fc25..36beb3a 100644 --- a/tests/var.test +++ b/tests/var.test @@ -1046,7 +1046,7 @@ test var-22.2 {leak in parsedVarName} -constraints memory -body { } -cleanup { unset -nocomplain i x } -result 0 - + unset -nocomplain a k v test var-23.1 {array command, for loop, too many args} -returnCodes error -body { array for {k v} c d e {} @@ -1202,6 +1202,261 @@ test var-23.14 {array for, shared arguments} -setup { } -cleanup { unset -nocomplain $vn vn } -result {} + +test var-24.1 {array default set and get: interpreted} -setup { + unset -nocomplain ary +} -body { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [info exist ary(a)] [info exist ary(b)] \ + [array default get ary] +} -cleanup { + unset -nocomplain ary +} -result {3 7 1 0 7} +test var-24.2 {array default set and get: compiled} { + apply {{} { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [info exist ary(a)] [info exist ary(b)] \ + [array default get ary] + }} +} {3 7 1 0 7} +test var-24.3 {array default unset: interpreted} -setup { + unset -nocomplain ary +} -body { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [array default unset ary] $ary(a) [catch {set ary(b)}] +} -cleanup { + unset -nocomplain ary +} -result {3 7 {} 3 1} +test var-24.4 {array default unset: compiled} { + apply {{} { + array set ary {a 3} + array default set ary 7 + list $ary(a) $ary(b) [array default unset ary] $ary(a) \ + [catch {set ary(b)}] + }} +} {3 7 {} 3 1} +test var-24.5 {array default exists: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array set ary {a 3} + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 7 + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 11 + lappend result [info exists ary],[array exists ary],[array default exists ary] +} -cleanup { + unset -nocomplain ary result +} -result {1,1,0 1,1,1 1,1,0 0,0,0 1,1,1} +test var-24.6 {array default exists: compiled} { + apply {{} { + array set ary {a 3} + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 7 + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + unset ary + lappend result [info exists ary],[array exists ary],[array default exists ary] + array default set ary 11 + lappend result [info exists ary],[array exists ary],[array default exists ary] + }} +} {1,1,0 1,1,1 1,1,0 0,0,0 1,1,1} +test var-24.7 {array default and append: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + append ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + append ary(x) def + append ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) +} -cleanup { + unset -nocomplain ary result +} -result {0 0 1 grillabc 2 grillabcdef ghi} +test var-24.8 {array default and append: compiled} { + apply {{} { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + append ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + append ary(x) def + append ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) + }} +} {0 0 1 grillabc 2 grillabcdef ghi} +test var-24.9 {array default and lappend: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + lappend ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + lappend ary(x) def + lappend ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) +} -cleanup { + unset -nocomplain ary result +} -result {0 0 1 {grill abc} 2 {grill abc def} ghi} +test var-24.10 {array default and lappend: compiled} { + apply {{} { + array default set ary grill + lappend result [array size ary] [info exist ary(x)] + lappend ary(x) abc + lappend result [array size ary] $ary(x) + array default unset ary + lappend ary(x) def + lappend ary(y) ghi + lappend result [array size ary] $ary(x) $ary(y) + }} +} {0 0 1 {grill abc} 2 {grill abc def} ghi} +test var-24.11 {array default and incr: interpreted} -setup { + unset -nocomplain ary result + set result {} +} -body { + array default set ary 7 + lappend result [array size ary] [info exist ary(x)] + incr ary(x) 11 + lappend result [array size ary] $ary(x) + array default unset ary + incr ary(x) + incr ary(y) + lappend result [array size ary] $ary(x) $ary(y) +} -cleanup { + unset -nocomplain ary result +} -result {0 0 1 18 2 19 1} +test var-24.12 {array default and incr: compiled} { + apply {{} { + array default set ary 7 + lappend result [array size ary] [info exist ary(x)] + incr ary(x) 11 + lappend result [array size ary] $ary(x) + array default unset ary + incr ary(x) + incr ary(y) + lappend result [array size ary] $ary(x) $ary(y) + }} +} {0 0 1 18 2 19 1} +test var-24.13 {array default and dict: interpreted} -setup { + unset -nocomplain ary x y z +} -body { + array default set ary {x y} + dict lappend ary(p) x z + dict update ary(q) x y { + set y z + } + dict with ary(r) { + set x 123 + } + lsort -stride 2 -index 0 [array get ary] +} -cleanup { + unset -nocomplain ary x y z +} -result {p {x {y z}} q {x z} r {x 123}} +test var-24.14 {array default and dict: compiled} { + lsort -stride 2 -index 0 [apply {{} { + array default set ary {x y} + dict lappend ary(p) x z + dict update ary(q) x y { + set y z + } + dict with ary(r) { + set x 123 + } + array get ary + }}] +} {p {x {y z}} q {x z} r {x 123}} +test var-24.15 {array default set and get: two-level} { + apply {{} { + array set ary {a 3} + array default set ary 7 + apply {{} { + upvar 1 ary ary ary(c) c + lappend result $ary(a) $ary(b) $c + lappend result [info exist ary(a)] [info exist ary(b)] [info exist c] + lappend result [array default get ary] + }} + }} +} {3 7 7 1 0 0 7} +test var-24.16 {array default set: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default set ary 7 +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {can't array default set "ary": variable isn't array} +test var-24.17 {array default set: errors} -setup { + unset -nocomplain ary +} -body { + array default set ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.18 {array default set: errors} -setup { + unset -nocomplain ary +} -body { + array default set ary x y +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.19 {array default get: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default get ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {"ary" isn't an array} +test var-24.20 {array default get: errors} -setup { + unset -nocomplain ary +} -body { + array default get ary x y +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.21 {array default exists: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default exists ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {"ary" isn't an array} +test var-24.22 {array default exists: errors} -setup { + unset -nocomplain ary +} -body { + array default exists ary x +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob +test var-24.23 {array default unset: errors} -setup { + unset -nocomplain ary +} -body { + set ary not-an-array + array default unset ary +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result {"ary" isn't an array} +test var-24.24 {array default unset: errors} -setup { + unset -nocomplain ary +} -body { + array default unset ary x +} -returnCodes error -cleanup { + unset -nocomplain ary +} -result * -match glob catch {namespace delete ns} catch {unset arr} diff --git a/tests/winFCmd.test b/tests/winFCmd.test index 1767712..a0b7053 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -56,10 +56,9 @@ proc cleanup {args} { } if {[testConstraint win]} { - set major [string index $tcl_platform(osVersion) 0] - if {$major > 5} { + if {$::tcl_platform(osVersion) >= 5.0} { testConstraint winVista 1 - } elseif {$major == 5} { + } else { testConstraint winXP 1 } } diff --git a/tests/winPipe.test b/tests/winPipe.test index 53e46fc..361858a 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -30,6 +30,7 @@ testConstraint cat32 [file exists $cat32] testConstraint AllocConsole [catch {puts console1 ""}] testConstraint RealConsole [expr {![testConstraint AllocConsole]}] testConstraint testexcept [llength [info commands testexcept]] +testConstraint slowTest 0 set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n @@ -308,9 +309,54 @@ test winpipe-6.2 {PipeSetupProc & PipeCheckProc: write threads} \ lappend x [catch {close $f} msg] $msg } {writable timeout 0 {}} -set path(echoArgs.tcl) [makeFile { - puts "[list $argv0 $argv]" -} echoArgs.tcl] +proc _testExecArgs {single args} { + variable path + if {![info exists path(echoArgs.tcl)] || ![file exists $path(echoArgs.tcl)]} { + set path(echoArgs.tcl) [makeFile { + puts "[list [file tail $argv0] {*}$argv]" + } echoArgs.tcl] + } + if {![info exists path(echoArgs.bat)] || ![file exists $path(echoArgs.bat)]} { + set path(echoArgs.bat) [makeFile "@[file native [interpreter]] $path(echoArgs.tcl) %*" "echoArgs.bat"] + } + set cmds [list [list [interpreter] $path(echoArgs.tcl)]] + if {!($single & 2)} { + lappend cmds [list $path(echoArgs.bat)] + } else { + if {![info exists path(echoArgs2.bat)] || ![file exists $path(echoArgs2.bat)]} { + set path(echoArgs2.bat) [makeFile \ + "@[file native [interpreter]] $path(echoArgs.tcl) %*" \ + "echo(Cmd)Test Args & Batch.bat" [makeDirectory test(Dir)Check]] + } + lappend cmds [list $path(echoArgs2.bat)] + } + set broken {} + foreach args $args { + if {$single & 1} { + # enclose single test-arg between 1st/3rd to be sure nothing is truncated + # (e. g. to cover unexpected trim by nts-zero case, and args don't recombined): + set args [list "1st" $args "3rd"] + } + set args [list {*}$args]; # normalized canonical list + foreach cmd $cmds { + set e [linsert $args 0 [file tail $path(echoArgs.tcl)]] + tcltest::DebugPuts 4 " ## test exec [file extension [lindex $cmd 0]] ($cmd) for\n ## $args" + if {[catch { + exec {*}$cmd {*}$args + } r]} { + set r "ERROR: $r" + } + if {$r ne $e} { + append broken "\[ERROR\]: exec [file extension [lindex $cmd 0]] on $args\n -- result:\n$r\n -- expected:\n$e\n" + } + if {$single & 8} { + # if test exe only: + break + } + } + } + return $broken +} ### validate the raw output of BuildCommandLine(). ### @@ -369,65 +415,178 @@ test winpipe-7.18 {BuildCommandLine: special chars #5} {win exec} { exec $env(COMSPEC) /c echo foo \} bar } "foo \} bar" +set injectList { + {test"whoami} {test""whoami} + {test"""whoami} {test""""whoami} + + "test\"whoami\\" "test\"\"whoami\\" + "test\"\"\"whoami\\" "test\"\"\"\"whoami\\" + + {test\\&\\test} {test"\\&\\test} + {"test\\&\\test} {"test"\\&\\"test"} + {test\\"&"\\test} {test"\\"&"\\test} + {"test\\"&"\\test} {"test"\\"&"\\"test"} + + {test\"&whoami} {test"\"&whoami} + {test""\"&whoami} {test"""\"&whoami} + {test\"\&whoami} {test"\"\&whoami} + {test""\"\&whoami} {test"""\"\&whoami} + + {test&whoami} {test|whoami} + {"test&whoami} {"test|whoami} + {test"&whoami} {test"|whoami} + {"test"&whoami} {"test"|whoami} + {""test"&whoami} {""test"|whoami} + + {test&echo "} {test|echo "} + {"test&echo "} {"test|echo "} + {test"&echo "} {test"|echo "} + {"test"&echo "} {"test"|echo "} + {""test"&echo "} {""test"|echo "} + + {test&echo ""} {test|echo ""} + {"test&echo ""} {"test|echo ""} + {test"&echo ""} {test"|echo ""} + {"test"&echo ""} {"test"|echo ""} + {""test"&echo ""} {""test"|echo ""} + + {test>whoami} {test<whoami} + {"test>whoami} {"test<whoami} + {test">whoami} {test"<whoami} + {"test">whoami} {"test"<whoami} + {""test">whoami} {""test"<whoami} + {test(whoami)} {test(whoami)} + {test"(whoami)} {test"(whoami)} + {test^whoami} {test^^echo ^^^} + {test"^whoami} {test"^^echo ^^^} + {test"^echo ^^^"} {test""^echo" ^^^"} + + {test%USERDOMAIN%\%USERNAME%} + {test" %USERDOMAIN%\%USERNAME%} + {test%USERDOMAIN%\\%USERNAME%} + {test" %USERDOMAIN%\\%USERNAME%} + {test%USERDOMAIN%&%USERNAME%} + {test" %USERDOMAIN%&%USERNAME%} + {test%USERDOMAIN%\&\%USERNAME%} + {test" %USERDOMAIN%\&\%USERNAME%} + + {test%USERDOMAIN%\&\test} + {test" %USERDOMAIN%\&\test} + {test%USERDOMAIN%\\&\\test} + {test" %USERDOMAIN%\\&\\test} + + {test%USERDOMAIN%\&\"test} + {test" %USERDOMAIN%\&\"test} + {test%USERDOMAIN%\\&\\"test} + {test" %USERDOMAIN%\\&\\"test} +} + ### validate the pass-thru from BuildCommandLine() to the crt's parse_cmdline(). ### -test winpipe-8.1 {BuildCommandLine/parse_cmdline pass-thru: null arguments} {win exec} { - exec [interpreter] $path(echoArgs.tcl) foo "" bar -} [list $path(echoArgs.tcl) [list foo {} bar]] -test winpipe-8.2 {BuildCommandLine/parse_cmdline pass-thru: null arguments} {win exec} { - exec [interpreter] $path(echoArgs.tcl) foo {} bar -} [list $path(echoArgs.tcl) [list foo {} bar]] -test winpipe-8.3 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #1} {win exec} { - exec [interpreter] $path(echoArgs.tcl) foo "\"" bar -} [list $path(echoArgs.tcl) [list foo "\"" bar]] -test winpipe-8.4 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #2} {win exec} { - exec [interpreter] $path(echoArgs.tcl) foo {""} bar -} [list $path(echoArgs.tcl) [list foo {""} bar]] -test winpipe-8.5 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #3} {win exec} { - exec [interpreter] $path(echoArgs.tcl) foo "\" " bar -} [list $path(echoArgs.tcl) [list foo "\" " bar]] -test winpipe-8.6 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #4} {win exec} { - exec [interpreter] $path(echoArgs.tcl) foo {a="b"} bar -} [list $path(echoArgs.tcl) [list foo {a="b"} bar]] -test winpipe-8.7 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #5} {win exec} { - exec [interpreter] $path(echoArgs.tcl) foo {a = "b"} bar -} [list $path(echoArgs.tcl) [list foo {a = "b"} bar]] -test winpipe-8.8 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #6} {win exec} { - exec [interpreter] $path(echoArgs.tcl) {"hello"} {""hello""} {"""hello"""} {"\"hello\""} {he llo} {he " llo} -} [list $path(echoArgs.tcl) [list {"hello"} {""hello""} {"""hello"""} {"\"hello\""} {he llo} {he " llo}]] -test winpipe-8.9 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #1} {win exec} { - exec [interpreter] $path(echoArgs.tcl) foo \\ bar -} [list $path(echoArgs.tcl) [list foo \\ bar]] -test winpipe-8.10 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #2} {win exec} { - exec [interpreter] $path(echoArgs.tcl) foo \\\\ bar -} [list $path(echoArgs.tcl) [list foo \\\\ bar]] -test winpipe-8.11 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #3} {win exec} { - exec [interpreter] $path(echoArgs.tcl) foo \\\ \\ bar -} [list $path(echoArgs.tcl) [list foo \\\ \\ bar]] -test winpipe-8.12 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #4} {win exec} { - exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\\ bar -} [list $path(echoArgs.tcl) [list foo \\\ \\\\ bar]] -test winpipe-8.13 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #5} {win exec} { - exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\\\\ bar -} [list $path(echoArgs.tcl) [list foo \\\ \\\\\\ bar]] -test winpipe-8.14 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #6} {win exec} { - exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\" bar -} [list $path(echoArgs.tcl) [list foo \\\ \\\" bar]] -test winpipe-8.15 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #7} {win exec} { - exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\\\" bar -} [list $path(echoArgs.tcl) [list foo \\\ \\\\\" bar]] -test winpipe-8.16 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #8} {win exec} { - exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\\\\\" bar -} [list $path(echoArgs.tcl) [list foo \\\ \\\\\\\" bar]] -test winpipe-8.17 {BuildCommandLine/parse_cmdline pass-thru: special chars #1} {win exec} { - exec [interpreter] $path(echoArgs.tcl) foo \{ bar -} [list $path(echoArgs.tcl) [list foo \{ bar]] -test winpipe-8.18 {BuildCommandLine/parse_cmdline pass-thru: special chars #2} {win exec} { - exec [interpreter] $path(echoArgs.tcl) foo \} bar -} [list $path(echoArgs.tcl) [list foo \} bar]] -test winpipe-8.19 {ensure parse_cmdline isn't doing wildcard replacement} {win exec} { - exec [interpreter] $path(echoArgs.tcl) foo * makefile.?c bar -} [list $path(echoArgs.tcl) [list foo * makefile.?c bar]] +test winpipe-8.1 {BuildCommandLine/parse_cmdline pass-thru: dumped arguments are equal original} \ +-constraints {win exec} -body { + _testExecArgs 0 \ + [list foo "" bar] \ + [list foo {} bar] \ + [list foo "\"" bar] \ + [list foo {""} bar] \ + [list foo "\" " bar] \ + [list foo {a="b"} bar] \ + [list foo {a = "b"} bar] \ + [list {"hello"} {""hello""} {"""hello"""} {"\"hello\""} {he llo} {he " llo}] \ + [list foo \\ bar] \ + [list foo \\\\ bar] \ + [list foo \\\ \\ bar] \ + [list foo \\\ \\\\ bar] \ + [list foo \\\ \\\\\\ bar] \ + [list foo \\\ \\\" bar] \ + [list foo \\\ \\\\\" bar] \ + [list foo \\\ \\\\\\\" bar] \ + [list foo \{ bar] \ + [list foo \} bar] \ + [list foo * makefile.?c bar] +} -result {} + +test winpipe-8.2 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (particular)} \ +-constraints {win exec slowTest} -body { + _testExecArgs 1 {*}$injectList +} -result {} + +test winpipe-8.3 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (jointly)} \ +-constraints {win exec} -body { + _testExecArgs 0 \ + [list START {*}$injectList END] \ + [list "START\"" {*}$injectList END] \ + [list START {*}$injectList "\"END"] \ + [list "START\"" {*}$injectList "\"END"] +} -result {} + +test winpipe-8.4 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (command/jointly args)} \ +-constraints {win exec} -body { + _testExecArgs 2 \ + [list START {*}$injectList END] \ + [list "START\"" {*}$injectList END] \ + [list START {*}$injectList "\"END"] \ + [list "START\"" {*}$injectList "\"END"] +} -result {} + +test winpipe-8.5 {BuildCommandLine/parse_cmdline pass-thru: check injection on special meta-chars (random mix)} \ +-constraints {win exec} -body { + set lst {} + set maps { + {\&|^<>!()%} + {\&|^<>!()% } + {"\&|^<>!()%} + {"\&|^<>!()% } + {"""""\\\\\&|^<>!()%} + {"""""\\\\\&|^<>!()% } + } + set i 0 + time { + set args {[incr i].} + time { + set map [lindex $maps [expr {int(rand()*[llength $maps])}]] + # be sure arg has some prefix (avoid special handling, like |& etc) + set a {x} + while {[string length $a] < 50} { + append a [string index $map [expr {int(rand()*[string length $map])}]] + } + lappend args $a + } 20 + lappend lst $args + } 10 + _testExecArgs 0 {*}$lst +} -result {} -cleanup { + unset -nocomplain lst args a map maps +} + +set injectList { + "test\"\nwhoami" "test\"\"\nwhoami" + "test\"\"\"\nwhoami" "test\"\"\"\"\nwhoami" + "test;\n&echo \"" "\"test;\n&echo \"" + "test\";\n&echo \"" "\"test\";\n&echo \"" + "\"\"test\";\n&echo \"" +} + +test winpipe-8.6 {BuildCommandLine/parse_cmdline pass-thru: check new-line quoted in args} \ +-constraints {win exec} -body { + # test exe only, because currently there is no proper way to escape a new-line char resp. + # to supply a new-line to the batch-files within arguments (command line is truncated). + _testExecArgs 8 \ + [list START {*}$injectList END] \ + [list "START\"" {*}$injectList END] \ + [list START {*}$injectList "\"END"] \ + [list "START\"" {*}$injectList "\"END"] +} -result {} + +test winpipe-8.7 {BuildCommandLine/parse_cmdline pass-thru: check new-line quoted in args (batch)} \ +-constraints {win exec knownBug} -body { + # this will fail if executed batch-file, because currently there is no proper way to escape a new-line char. + _testExecArgs 0 $injectList +} -result {} + + +rename _testExecArgs {} # restore old values for env(TMP) and env(TEMP) @@ -445,7 +604,9 @@ removeFile more removeFile stdout removeFile stderr removeFile nothing -removeFile echoArgs.tcl +if {[info exists path(echoArgs.tcl)]} { removeFile echoArgs.tcl } +if {[info exists path(echoArgs.bat)]} { removeFile echoArgs.bat } +if {[info exists path(echoArgs2.bat)]} { removeDirectory test(Dir)Check } ::tcltest::cleanupTests return diff --git a/tests/zipfs.test b/tests/zipfs.test new file mode 100644 index 0000000..5715ce8 --- /dev/null +++ b/tests/zipfs.test @@ -0,0 +1,284 @@ +# The file tests the tclZlib.c file. +# +# This file contains a collection of tests for one or more of the Tcl built-in +# commands. Sourcing this file into Tcl runs the tests and generates output +# for errors. No output means no errors were found. +# +# Copyright (c) 1996-1998 by Sun Microsystems, Inc. +# 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. + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2.1 + namespace import -force ::tcltest::* +} + +testConstraint zipfs [expr { + [llength [info commands zlib]] && [regexp tcltest [info nameofexecutable]] +}] +testConstraint zipfslib 1 + +# Removed in tip430 - zipfs is no longer a static package +#test zipfs-0.0 {zipfs basics} -constraints zipfs -body { +# load {} zipfs +#} -result {} + +set ziproot [zipfs root] +set CWD [pwd] +set tmpdir [file join $CWD tmp] +file mkdir $tmpdir + +test zipfs-0.0 {zipfs basics} -constraints zipfs -body { + package require zipfs +} -result {2.0} +test zipfs-0.1 {zipfs basics} -constraints zipfs -body { + expr {${ziproot} in [file volumes]} +} -result 1 + +if {![string match ${ziproot}* $tcl_library]} { + ### + # "make test" does not map tcl_library from the dynamic library on Unix + # + # Hack the environment to pretend we did pull tcl_library from a zip + # archive + ### + set tclzip [file join $CWD [::tcl::pkgconfig get zipfile,runtime]] + testConstraint zipfslib [file exists $tclzip] + if {[testConstraint zipfslib]} { + zipfs mount /lib/tcl $tclzip + set ::tcl_library ${ziproot}lib/tcl/tcl_library + } +} + +test zipfs-0.2 {zipfs basics} -constraints zipfslib -body { + string match ${ziproot}* $tcl_library +} -result 1 +test zipfs-0.3 {zipfs basics: glob} -constraints zipfslib -setup { + set pwd [pwd] +} -body { + cd $tcl_library + lsort [glob -dir . http*] +} -cleanup { + cd $pwd +} -result {./http} +test zipfs-0.4 {zipfs basics: glob} -constraints zipfslib -setup { + set pwd [pwd] +} -body { + cd $tcl_library + lsort [glob -dir [pwd] http*] +} -cleanup { + cd $pwd +} -result [list $tcl_library/http] +test zipfs-0.5 {zipfs basics: glob} -constraints zipfslib -body { + lsort [glob -dir $tcl_library http*] +} -result [list $tcl_library/http] +test zipfs-0.6 {zipfs basics: glob} -constraints zipfslib -body { + lsort [glob $tcl_library/http*] +} -result [list $tcl_library/http] +test zipfs-0.7 {zipfs basics: glob} -constraints zipfslib -body { + lsort [glob -tails -dir $tcl_library http*] +} -result {http} +test zipfs-0.8 {zipfs basics: glob} -constraints zipfslib -body { + lsort [glob -nocomplain -tails -types d -dir $tcl_library http*] +} -result {http} +test zipfs-0.9 {zipfs basics: glob} -constraints zipfslib -body { + lsort [glob -nocomplain -tails -types f -dir $tcl_library http*] +} -result {} +test zipfs-0.10 {zipfs basics: join} -constraints {zipfs zipfslib} -body { + file join [zipfs root] bar baz +} -result "[zipfs root]bar/baz" +test zipfs-0.11 {zipfs basics: join} -constraints {zipfs zipfslib} -body { + file normalize [zipfs root] +} -result "[zipfs root]" +test zipfs-0.12 {zipfs basics: join} -constraints {zipfs zipfslib} -body { + file normalize [zipfs root]//bar/baz//qux/../ +} -result "[zipfs root]bar/baz" + +test zipfs-1.3 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs mount a b c d e f +} -result {wrong # args: should be "zipfs mount ?mountpoint? ?zipfile? ?password?"} +test zipfs-1.4 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs unmount a b c d e f +} -result {wrong # args: should be "zipfs unmount zipfile"} +test zipfs-1.5 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs mkkey a b c d e f +} -result {wrong # args: should be "zipfs mkkey password"} +test zipfs-1.6 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs mkimg a b c d e f +} -result {wrong # args: should be "zipfs mkimg outfile indir ?strip? ?password? ?infile?"} +test zipfs-1.7 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs mkzip a b c d e f +} -result {wrong # args: should be "zipfs mkzip outfile indir ?strip? ?password?"} +test zipfs-1.8 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs exists a b c d e f +} -result {wrong # args: should be "zipfs exists filename"} +test zipfs-1.9 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs info a b c d e f +} -result {wrong # args: should be "zipfs info filename"} +test zipfs-1.10 {zipfs errors} -constraints zipfs -returnCodes error -body { + zipfs list a b c d e f +} -result {wrong # args: should be "zipfs list ?(-glob|-regexp)? ?pattern?"} + +file mkdir tmp +test zipfs-2.1 {zipfs mkzip empty archive} -constraints zipfs -returnCodes error -body { + zipfs mkzip [file join $tmpdir empty.zip] $tcl_library/xxxx +} -result {empty archive} +### +# The next series of tests operate within a zipfile created a temporary +# directory. +### +set zipfile [file join $tmpdir abc.zip] +if {[file exists $zipfile]} { + file delete $zipfile +} +test zipfs-2.2 {zipfs mkzip} -constraints zipfs -body { + cd $tcl_library/encoding + zipfs mkzip $zipfile . + zipfs mount ${ziproot}abc $zipfile + zipfs list -glob ${ziproot}abc/cp850.* +} -cleanup { + cd $CWD +} -result "[zipfs root]abc/cp850.enc" +testConstraint zipfsenc [zipfs exists /abc/cp850.enc] +test zipfs-2.3 {zipfs info} -constraints {zipfs zipfsenc} -body { + set r [zipfs info ${ziproot}abc/cp850.enc] + lrange $r 0 2 +} -result [list $zipfile 1090 527] ;# NOTE: Only the first 3 results are stable +test zipfs-2.4 {zipfs data} -constraints {zipfs zipfsenc} -body { + set zipfd [open ${ziproot}/abc/cp850.enc] ;# FIXME: leave open - see later test + read $zipfd +} -result {# Encoding file: cp850, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +00C700FC00E900E200E400E000E500E700EA00EB00E800EF00EE00EC00C400C5 +00C900E600C600F400F600F200FB00F900FF00D600DC00F800A300D800D70192 +00E100ED00F300FA00F100D100AA00BA00BF00AE00AC00BD00BC00A100AB00BB +2591259225932502252400C100C200C000A9256325512557255D00A200A52510 +25142534252C251C2500253C00E300C3255A25542569256625602550256C00A4 +00F000D000CA00CB00C8013100CD00CE00CF2518250C2588258400A600CC2580 +00D300DF00D400D200F500D500B500FE00DE00DA00DB00D900FD00DD00AF00B4 +00AD00B1201700BE00B600A700F700B800B000A800B700B900B300B225A000A0 +} ;# FIXME: result depends on content of encodings dir +test zipfs-2.5 {zipfs exists} -constraints {zipfs zipfsenc} -body { + zipfs exists /abc/cp850.enc +} -result 1 +test zipfs-2.6 {zipfs unmount while busy} -constraints {zipfs zipfsenc} -body { + zipfs unmount /abc +} -returnCodes error -result {filesystem is busy} +test zipfs-2.7 {zipfs unmount} -constraints {zipfs zipfsenc} -body { + close $zipfd + zipfs unmount /abc + zipfs exists /abc/cp850.enc +} -result 0 +### +# Repeat the tests for a buffer mounted archive +### +test zipfs-2.8 {zipfs mkzip} -constraints zipfs -body { + cd $tcl_library/encoding + zipfs mkzip $zipfile . + set fin [open $zipfile r] + fconfigure $fin -translation binary + set dat [read $fin] + close $fin + zipfs mount_data def $dat + zipfs list -glob ${ziproot}def/cp850.* +} -cleanup { + cd $CWD +} -result "[zipfs root]def/cp850.enc" +testConstraint zipfsencbuf [zipfs exists /def/cp850.enc] +test zipfs-2.9 {zipfs info} -constraints {zipfs zipfsencbuf} -body { + set r [zipfs info ${ziproot}def/cp850.enc] + lrange $r 0 2 +} -result [list {Memory Buffer} 1090 527] ;# NOTE: Only the first 3 results are stable +test zipfs-2.10 {zipfs data} -constraints {zipfs zipfsencbuf} -body { + set zipfd [open ${ziproot}/def/cp850.enc] ;# FIXME: leave open - see later test + read $zipfd +} -result {# Encoding file: cp850, single-byte +S +003F 0 1 +00 +0000000100020003000400050006000700080009000A000B000C000D000E000F +0010001100120013001400150016001700180019001A001B001C001D001E001F +0020002100220023002400250026002700280029002A002B002C002D002E002F +0030003100320033003400350036003700380039003A003B003C003D003E003F +0040004100420043004400450046004700480049004A004B004C004D004E004F +0050005100520053005400550056005700580059005A005B005C005D005E005F +0060006100620063006400650066006700680069006A006B006C006D006E006F +0070007100720073007400750076007700780079007A007B007C007D007E007F +00C700FC00E900E200E400E000E500E700EA00EB00E800EF00EE00EC00C400C5 +00C900E600C600F400F600F200FB00F900FF00D600DC00F800A300D800D70192 +00E100ED00F300FA00F100D100AA00BA00BF00AE00AC00BD00BC00A100AB00BB +2591259225932502252400C100C200C000A9256325512557255D00A200A52510 +25142534252C251C2500253C00E300C3255A25542569256625602550256C00A4 +00F000D000CA00CB00C8013100CD00CE00CF2518250C2588258400A600CC2580 +00D300DF00D400D200F500D500B500FE00DE00DA00DB00D900FD00DD00AF00B4 +00AD00B1201700BE00B600A700F700B800B000A800B700B900B300B225A000A0 +} ;# FIXME: result depends on content of encodings dir +test zipfs-2.11 {zipfs exists} -constraints {zipfs zipfsencbuf} -body { + zipfs exists /def/cp850.enc +} -result 1 +test zipfs-2.12 {zipfs unmount while busy} -constraints {zipfs zipfsencbuf} -body { + zipfs unmount /def +} -returnCodes error -result {filesystem is busy} +test zipfs-2.13 {zipfs unmount} -constraints {zipfs zipfsencbuf} -body { + close $zipfd + zipfs unmount /def + zipfs exists /def/cp850.enc +} -result 0 + +catch {file delete -force $tmpdir} + +test zipfs-3.1 {zipfs in child interpreters} -constraints zipfs -setup { + set interp [interp create] +} -body { + interp eval $interp { + zipfs ? + } +} -returnCodes error -cleanup { + interp delete $interp +} -result {unknown or ambiguous subcommand "?": must be canonical, exists, find, info, list, lmkimg, lmkzip, mkimg, mkkey, mkzip, mount, mount_data, root, or unmount} +test zipfs-3.2 {zipfs in child interpreters} -constraints zipfs -setup { + set interp [interp create] +} -body { + interp eval $interp { + zipfs mkzip + } +} -returnCodes error -cleanup { + interp delete $interp +} -result {wrong # args: should be "zipfs mkzip outfile indir ?strip? ?password?"} +test zipfs-3.3 {zipfs in child interpreters} -constraints zipfs -setup { + set safe [interp create -safe] +} -body { + interp eval $safe { + zipfs ? + } +} -returnCodes error -cleanup { + interp delete $safe +} -result {unknown or ambiguous subcommand "?": must be canonical, exists, find, info, list, lmkimg, lmkzip, mkimg, mkkey, mkzip, mount, mount_data, root, or unmount} +test zipfs-3.4 {zipfs in child interpreters} -constraints zipfs -setup { + set safe [interp create -safe] +} -body { + interp eval $safe { + zipfs mkzip + } +} -returnCodes error -cleanup { + interp delete $safe +} -result {not allowed to invoke subcommand mkzip of zipfs} + +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End: |