diff options
Diffstat (limited to 'tests')
116 files changed, 10614 insertions, 3925 deletions
diff --git a/tests/README b/tests/README index ce2382e..e86100f 100644 --- a/tests/README +++ b/tests/README @@ -59,7 +59,7 @@ should correspond to the Tcl or C code file that they are testing. For example, the test file for the C file "tclCmdAH.c" is "cmdAH.test". Test files that contain black-box tests may not correspond to any Tcl or C code file so they should match the pattern -"*_bb.test". +"*_bb.test". Be sure your new test file can be run from any working directory. @@ -72,12 +72,12 @@ as well as an installation environment. If your test file contains tests that should not be run in one or more of those cases, please use the constraints mechanism to skip those tests. -4. Incompatibilities of package tcltest 2.1 with +4. Incompatibilities of package tcltest 2.1 with testing machinery of very old versions of Tcl: ------------------------------------------------ 1) Global variables such as VERBOSE, TESTS, and testConfig of the - old machinery correspond to the [configure -verbose], + old machinery correspond to the [configure -verbose], [configure -match], and [testConstraint] commands of tcltest 2.1, respectively. diff --git a/tests/all.tcl b/tests/all.tcl index 69a16ba..89a4f1a 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -13,10 +13,16 @@ 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 + +set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)] +unset -nocomplain env(ERROR_ON_FAILURES) +if {[runAllTests] && $ErrorOnFailures} {exit 1} proc exit args {} diff --git a/tests/apply.test b/tests/apply.test index ba19b81..597cd97 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -228,7 +228,7 @@ test apply-8.3 {args treatment} { apply [list {x args} $applyBody] 1 2 3 } {{x 1} {args {2 3}}} test apply-8.4 {default values} { - apply [list {{x 1} {y 2}} $applyBody] + apply [list {{x 1} {y 2}} $applyBody] } {{x 1} {y 2}} test apply-8.5 {default values} { apply [list {{x 1} {y 2}} $applyBody] 3 4 diff --git a/tests/assemble.test b/tests/assemble.test index 5231048..05c1f9b 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -12,7 +12,7 @@ # Commands covered: assemble if {"::tcltest" ni [namespace children]} { - package require tcltest 2.2 + package require tcltest 2.5 namespace import -force ::tcltest::* } namespace eval tcl::unsupported {namespace export assemble} @@ -301,12 +301,12 @@ test assemble-7.1 {add, wrong # args} { -result {wrong # args*} } test assemble-7.2 {add} { - -body { + -body { assemble { push 2 push 2 add - } + } } -result {4} } @@ -349,7 +349,7 @@ test assemble-7.5 {bitwise ops} { } test assemble-7.6 {div} { -body { - assemble {push 999999; push 7; div} + assemble {push 999999; push 7; div} } -result 142857 } @@ -360,7 +360,7 @@ test assemble-7.7 {dup} { } } -result 9 -} +} test assemble-7.8 {eq} { -body { list \ @@ -638,7 +638,7 @@ test assemble-7.24 {lsetList} { test assemble-7.25 {lshift} { -body { assemble {push 16; push 4; lshift} - } + } -result 256 } test assemble-7.26 {mod} { @@ -678,7 +678,7 @@ test assemble-7.30 {pop} { test assemble-7.31 {rshift} { -body { assemble {push 257; push 4; rshift} - } + } -result 16 } test assemble-7.32 {storeArrayStk} { @@ -852,10 +852,11 @@ test assemble-8.5 {bad context} { -body { namespace eval assem { set x 1 - list [catch {assemble {load x}} result opts] $result [dict get $opts -errorcode] + assemble {load x} } } - -result {1 {cannot use this instruction to create a variable in a non-proc context} {TCL ASSEM LVT}} + -result {cannot use this instruction to create a variable in a non-proc context} + -errorCode {TCL ASSEM LVT} -cleanup {namespace delete assem} } test assemble-8.6 {load1} { @@ -1110,10 +1111,10 @@ test assemble-9.6 {concat} { } test assemble-9.7 {concat} { -body { - list [catch {assemble {concat 0}} result] $result $::errorCode + assemble {concat 0} } - -result {1 {operand must be positive} {TCL ASSEM POSITIVE}} - -cleanup {unset result} + -result {operand must be positive} + -errorCode {TCL ASSEM POSITIVE} } # assemble-10 -- eval and expr @@ -1201,7 +1202,7 @@ test assemble-10.7 {expr - noncompilable} { # assemble-11 - ASSEM_LVT4 (exist, existArray, dictAppend, dictLappend, # nsupvar, variable, upvar) - + test assemble-11.1 {exist - wrong # args} { -body { assemble {exist} @@ -1310,7 +1311,7 @@ test assemble-11.10 {variable} { } # assemble-12 - ASSEM_LVT1 (incr and incrArray) - + test assemble-12.1 {incr - wrong # args} { -body { assemble {incr} @@ -1584,6 +1585,12 @@ test assemble-15.7 {listIndexImm} { } -result c } +test assemble-15.8 {listIndexImm} { + assemble {push {a b c}; listIndexImm end+2} +} {} +test assemble-15.9 {listIndexImm} { + assemble {push {a b c}; listIndexImm -1-1} +} {} # assemble-16 - invokeStk @@ -1743,16 +1750,16 @@ test assemble-17.9 {jump - resolve a label multiple times} { set result {} assemble { jump common - + label zero - pop + pop incrImm case 1 pop push a append result pop jump common - + label one pop incrImm case 1 @@ -1761,7 +1768,7 @@ test assemble-17.9 {jump - resolve a label multiple times} { append result pop jump common - + label common load case dup @@ -1780,7 +1787,7 @@ test assemble-17.9 {jump - resolve a label multiple times} { push 3 eq jumpTrue three - + label two pop incrImm case 1 @@ -1789,7 +1796,7 @@ test assemble-17.9 {jump - resolve a label multiple times} { append result pop jump common - + label three pop incrImm case 1 @@ -1887,7 +1894,7 @@ test assemble-17.15 {multiple passes of code resizing} { append body {label b15; push b; concat 2; nop; nop; jump c} \n append body {label d} proc x {} [list assemble $body] - } + } -body { x } @@ -2080,7 +2087,7 @@ test assemble-20.5 {lsetFlat - negative operand count} { test assemble-20.6 {lsetFlat} { -body { assemble {push b; push a; lsetFlat 2} - } + } -result b } test assemble-20.7 {lsetFlat} { @@ -3066,12 +3073,12 @@ test assemble-40.1 {unbalanced stack} { [catch { assemble { push 3 - dup - mult + dup + mult push 4 - dup - mult - pop + dup + mult + pop expon } } result] $result $::errorInfo @@ -3170,7 +3177,7 @@ test assemble-50.1 {Ulam's 3n+1 problem, TAL implementation} { load n; # max dup; # max n jump start; # max n - + label loop; # max n over 1; # max n max over 1; # max in max n @@ -3180,29 +3187,29 @@ test assemble-50.1 {Ulam's 3n+1 problem, TAL implementation} { reverse 2; # n max pop; # n dup; # n n - + label skip; # max n dup; # max n n push 2; # max n n 2 mod; # max n n%2 jumpTrue odd; # max n - + push 2; # max n 2 div; # max n/2 -> max n jump start; # max n - + label odd; # max n push 3; # max n 3 mult; # max 3*n push 1; # max 3*n 1 add; # max 3*n+1 - + label start; # max n dup; # max n n push 1; # max n n 1 neq; # max n n>1 jumpTrue loop; # max n - + pop; # max } } @@ -3232,7 +3239,7 @@ test assemble-51.3 {memory leak testing} memory { load n; # max dup; # max n jump start; # max n - + label loop; # max n over 1; # max n max over 1; # max in max n @@ -3242,29 +3249,29 @@ test assemble-51.3 {memory leak testing} memory { reverse 2; # n max pop; # n dup; # n n - + label skip; # max n dup; # max n n push 2; # max n n 2 mod; # max n n%2 jumpTrue odd; # max n - + push 2; # max n 2 div; # max n/2 -> max n jump start; # max n - + label odd; # max n push 3; # max n 3 mult; # max 3*n push 1; # max 3*n 1 add; # max 3*n+1 - + label start; # max n dup; # max n n push 1; # max n n 1 neq; # max n n>1 jumpTrue loop; # max n - + pop; # max } }} 1 @@ -3297,7 +3304,7 @@ test assemble-52.1 {Bug 3154ea2759} { label @okLabel endCatch pop - + beginCatch @badLabel2 push error push testing @@ -3310,7 +3317,7 @@ test assemble-52.1 {Bug 3154ea2759} { label @okLabel2 endCatch pop - + beginCatch @badLabel3 push error push testing @@ -3323,7 +3330,7 @@ test assemble-52.1 {Bug 3154ea2759} { label @okLabel3 endCatch pop - + beginCatch @badLabel4 push error push testing @@ -3336,7 +3343,7 @@ test assemble-52.1 {Bug 3154ea2759} { label @okLabel4 endCatch pop - + beginCatch @badLabel5 push error push testing @@ -3349,7 +3356,7 @@ test assemble-52.1 {Bug 3154ea2759} { label @okLabel5 endCatch pop - + beginCatch @badLabel6 push error push testing diff --git a/tests/assemble1.bench b/tests/assemble1.bench index 18fd3a9..e294108 100644 --- a/tests/assemble1.bench +++ b/tests/assemble1.bench @@ -20,7 +20,7 @@ proc ulam2 {n} { load n; # max dup; # max n jump start; # max n - + label loop; # max n over 1; # max n max over 1; # max in max n @@ -30,29 +30,29 @@ proc ulam2 {n} { reverse 2; # n max pop; # n dup; # n n - + label skip; # max n dup; # max n n push 2; # max n n 2 mod; # max n n%2 jumpTrue odd; # max n - + push 2; # max n 2 div; # max n/2 -> max n jump start; # max n - + label odd; # max n push 3; # max n 3 mult; # max 3*n push 1; # max 3*n 1 add; # max 3*n+1 - + label start; # max n dup; # max n n push 1; # max n n 1 neq; # max n n>1 jumpTrue loop; # max n - + pop; # max } } @@ -60,12 +60,12 @@ set tcl_traceCompile 2; ulam2 1; set tcl_traceCompile 0 proc test1 {n} { for {set i 1} {$i <= $n} {incr i} { - ulam1 $i + ulam1 $i } } proc test2 {n} { for {set i 1} {$i <= $n} {incr i} { - ulam2 $i + ulam2 $i } } @@ -75,11 +75,10 @@ for {set j 0} {$j < 10} {incr j} { test1 30000 set after [clock microseconds] puts "compiled: [expr {1e-6 * ($after - $before)}]" - + test2 1 set before [clock microseconds] test2 30000 set after [clock microseconds] puts "assembled: [expr {1e-6 * ($after - $before)}]" } -
\ No newline at end of file diff --git a/tests/async.test b/tests/async.test index cb67cc2..34c2fdc 100644 --- a/tests/async.test +++ b/tests/async.test @@ -20,7 +20,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} { catch [list package require -exact Tcltest [info patchlevel]] testConstraint testasync [llength [info commands testasync]] -testConstraint threaded [::tcl::pkgconfig get threaded] proc async1 {result code} { global aresult acode @@ -149,7 +148,7 @@ test async-3.1 {deleting handlers} testasync { } {3 del2 {0 0 0 del1 del2}} test async-4.1 {async interrupting bytecode sequence} -constraints { - testasync threaded + testasync } -setup { set hm [testasync create async3] proc nothing {} { @@ -157,21 +156,28 @@ 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 { - testasync threaded + testasync } -setup { set hm [testasync create async3] } -body { @@ -179,16 +185,24 @@ 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 { - testasync threaded + testasync } -setup { set hm [testasync create async3] } -body { @@ -201,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/autoMkindex.test b/tests/autoMkindex.test index 4721553..b42d50d 100644 --- a/tests/autoMkindex.test +++ b/tests/autoMkindex.test @@ -180,7 +180,7 @@ test autoMkindex-3.1 {slaveHook} -setup { } -cleanup { # Reset initCommands to avoid trashing other tests AutoMkindexTestReset -} -result 1 +} -result 1 # The auto_mkindex_parser::command is used to register commands that create # new commands. test autoMkindex-3.2 {auto_mkindex_parser::command} -setup { diff --git a/tests/basic.test b/tests/basic.test index 865814a..2332994 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -256,7 +256,7 @@ test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace quali } list [test_ns_basic::p] \ [rename test_ns_basic::p test_ns_basic::q] \ - [test_ns_basic::q] + [test_ns_basic::q] } {{p in ::test_ns_basic} {} {p in ::test_ns_basic}} test basic-18.2 {TclRenameCommand, existing cmd must be found} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -469,11 +469,11 @@ test basic-26.2 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} -body { # a - the pure-list internal rep is destroyed by shimmering # b - the command returns an error # As the error code in Tcl_EvalObjv accesses the list elements, this will - # cause a segfault if [Bug 1119369] has not been fixed. + # cause a segfault if [Bug 1119369] has not been fixed. # NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault. # - set SRC [list foo 1] ;# pure-list command + set SRC [list foo 1] ;# pure-list command proc foo str { # Shimmer pure-list to cmdName, cleanup and error proc $::SRC {} {}; $::SRC @@ -491,11 +491,11 @@ test basic-26.3 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} -body { # Follow the pure-list branch in a manner that # a - the pure-list internal rep is destroyed by shimmering # b - the command accesses its command line - # This will cause a segfault if [Bug 1119369] has not been fixed. + # This will cause a segfault if [Bug 1119369] has not been fixed. # NOTE: a MEM_DEBUG build may be necessary to guarantee the segfault. # - set SRC [list foo 1] ;# pure-list command + set SRC [list foo 1] ;# pure-list command proc foo str { # Shimmer pure-list to cmdName, cleanup and error proc $::SRC {} {}; $::SRC @@ -607,7 +607,7 @@ test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} -setup { invoked "break" outside of a loop while executing "break" - (file "*BREAKtest" line 3)} + (file "*BREAKtest" line 3)} test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} -setup { set fName [makeFile { @@ -624,7 +624,7 @@ test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} -setup { } -returnCodes error -match glob -result {invoked "break" outside of a loop while executing "break" - (file "*BREAKtest" line 4)} + (file "*BREAKtest" line 4)} test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} -setup { set fName [makeFile { @@ -670,7 +670,7 @@ proc l3 {} { } # Do all tests once byte compiled and once with direct string evaluation -for {set noComp 0} {$noComp <= 1} {incr noComp} { +foreach noComp {0 1} { if $noComp { interp alias {} run {} testevalex @@ -752,7 +752,7 @@ test basic-48.1.$noComp {expansion: parsing} $constraints { # Another comment list 1 2\ 3 {*}$::l1 - + # Comment again } } {1 2 3 a {b b} c d} @@ -825,7 +825,7 @@ test basic-48.13.$noComp {expansion: odd usage} $constraints { test basic-48.14.$noComp {expansion: hash command} -setup { catch {rename \# ""} set cmd "#" - } -constraints $constraints -body { + } -constraints $constraints -body { run { {*}$cmd apa bepa } } -cleanup { unset cmd @@ -885,7 +885,7 @@ test basic-48.16.$noComp {expansion: testing for leaks} -setup { stress set tmp $end set end [getbytes] - } + } set leak [expr {$end - $tmp}] } -cleanup { unset end i tmp @@ -893,21 +893,17 @@ test basic-48.16.$noComp {expansion: testing for leaks} -setup { rename stress {} } -result 0 -test basic-48.17.$noComp {expansion: object safety} -setup { - set old_precision $::tcl_precision - set ::tcl_precision 4 - } -constraints $constraints -body { +test basic-48.17.$noComp {expansion: object safety} -constraints $constraints -body { set third [expr {1.0/3.0}] set l [list $third $third] set x [run {list $third {*}$l $third}] - set res [list] + set res [list] foreach t $x { lappend res [expr {$t * 3.0}] } set res } -cleanup { - set ::tcl_precision $old_precision - unset old_precision res t l x third + unset res t l x third } -result {1.0 1.0 1.0 1.0} test basic-48.18.$noComp {expansion: list semantics} -constraints $constraints -body { diff --git a/tests/binary.test b/tests/binary.test index 2a306a3..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 @@ -2849,6 +2858,19 @@ test binary-76.2 {binary string appending growth algorithm} win { # Append to it string length [append str [binary format a* foo]] } 3 + +test binary-77.1 {string cat ops on all bytearrays} { + apply {{a b} { + return [binary format H* $a][binary format H* $b] + }} ab cd +} [binary format H* abcd] +test binary-77.2 {string cat ops on all bytearrays} { + apply {{a b} { + set one [binary format H* $a] + return $one[binary format H* $b] + }} ab cd +} [binary format H* abcd] + # ---------------------------------------------------------------------- # cleanup diff --git a/tests/case.test b/tests/case.test index 6d63cea..d7558a9 100644 --- a/tests/case.test +++ b/tests/case.test @@ -11,6 +11,11 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. +if {![llength [info commands case]]} { + # No "case" command? So no need to test + return +} + if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* diff --git a/tests/chan.test b/tests/chan.test index d8390e2..6808453 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -135,7 +135,7 @@ test chan-16.4 {chan command: pending subcommand} -body { chan pending {input output} stdout } -returnCodes error -result "bad mode \"input output\": must be input or output" test chan-16.5 {chan command: pending input subcommand} -body { - chan pending input stdout + chan pending input stdout } -result -1 test chan-16.6 {chan command: pending input subcommand} -body { chan pending input stdin @@ -194,7 +194,7 @@ test chan-16.9 {chan command: pending input subcommand} -setup { set ::chan-16.9-data [list] set ::chan-16.9-done 0 } -body { - after idle chan-16.9-client + after idle chan-16.9-client vwait ::chan-16.9-done set ::chan-16.9-data } -result {-1 0 0 1 36 -1 0 0 1 72 -1 0 0 1 108 -1 0 0 1 144 ABC 890} -cleanup { diff --git a/tests/chanio.test b/tests/chanio.test index 86c1485..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... @@ -130,10 +123,10 @@ test chan-io-1.8 {Tcl_WriteChars: WriteChars} { # Executing this test without the fix for the referenced bug applied to # tcl will cause tcl, more specifically WriteChars, to go into an infinite # loop. - set f [open $path(test2) w] - chan configure $f -encoding iso2022-jp - chan puts -nonewline $f [format %s%c [string repeat " " 4] 12399] - chan close $f + set f [open $path(test2) w] + chan configure $f -encoding iso2022-jp + chan puts -nonewline $f [format %s%c [string repeat " " 4] 12399] + chan close $f contents $path(test2) } " \x1b\$B\$O\x1b(B" test chan-io-1.9 {Tcl_WriteChars: WriteChars} { @@ -248,7 +241,7 @@ test chan-io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} -bod test chan-io-3.4 {WriteChars: loop over stage buffer} { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] - chan configure $f -encoding jis0208 -buffersize 16 + chan configure $f -encoding jis0208 -buffersize 16 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] chan close $f @@ -259,7 +252,7 @@ test chan-io-3.5 {WriteChars: saved != 0} { # be moved to beginning of next channel buffer to preserve requested # buffersize. set f [open $path(test1) w] - chan configure $f -encoding jis0208 -buffersize 17 + chan configure $f -encoding jis0208 -buffersize 17 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] chan close $f @@ -288,7 +281,7 @@ test chan-io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} { # on flush. The truncated bytes are moved to the beginning of the next # channel buffer. set f [open $path(test1) w] - chan configure $f -encoding jis0208 -buffersize 17 + chan configure $f -encoding jis0208 -buffersize 17 chan puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] chan close $f @@ -353,7 +346,7 @@ test chan-io-4.5 {TranslateOutputEOL: crlf} { test chan-io-5.1 {CheckFlush: not full} { set f [open $path(test1) w] - chan configure $f + chan configure $f chan puts -nonewline $f "12345678901234567890" set x [list [contents $path(test1)]] chan close $f @@ -441,7 +434,7 @@ set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" append a $a append a $a test chan-io-6.6 {Tcl_GetsObj: loop test} -body { - # if (dst >= dstEnd) + # if (dst >= dstEnd) set f [open $path(test1) w] chan puts $f $a chan puts $f hi @@ -750,7 +743,7 @@ test chan-io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} -body { chan close $f } -result [list 16 "123456789012345\r" 1] test chan-io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} -body { - # not (*eol == '\n') + # not (*eol == '\n') set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "123456789012345\rabcd\r\nefg" @@ -860,7 +853,7 @@ test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup { chan configure $f -buffersize 16 lappend x [chan gets $f] chan configure $f -blocking 0 - lappend x [chan gets $f line] $line [testchannel queuedcr $f] + lappend x [chan gets $f line] $line [testchannel queuedcr $f] chan configure $f -blocking 1 chan puts -nonewline $f "\nabcd\refg\x1a" lappend x [chan gets $f line] $line [testchannel queuedcr $f] @@ -871,14 +864,14 @@ test chan-io-6.43 {Tcl_GetsObj: input saw cr} -setup { test chan-io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} -setup { set x "" } -constraints {stdio testchannel openpipe fileevent} -body { - # not (*eol == '\n') + # not (*eol == '\n') set f [openpipe w+ $path(cat)] chan configure $f -translation {auto lf} -buffering none chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r" chan configure $f -buffersize 16 lappend x [chan gets $f] chan configure $f -blocking 0 - lappend x [chan gets $f line] $line [testchannel queuedcr $f] + lappend x [chan gets $f line] $line [testchannel queuedcr $f] chan configure $f -blocking 1 chan puts -nonewline $f "abcd\refg\x1a" lappend x [chan gets $f line] $line [testchannel queuedcr $f] @@ -957,7 +950,7 @@ test chan-io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} -constraints {test chan close $f } -result {123456 0 8 78901} test chan-io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} -constraints {testchannel} -body { - # not (*eol == '\n') + # not (*eol == '\n') set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "123456\r78901" @@ -1183,7 +1176,7 @@ test chan-io-8.5 {PeekAhead: don't peek if last read was short} -constraints {st chan close $f } -result {15 abcdefghijklmno 1} test chan-io-8.6 {PeekAhead: change to non-blocking mode} -constraints {stdio testchannel openpipe fileevent} -body { - # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) + # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) set f [openpipe w+ $path(cat)] chan configure $f -translation {auto binary} -buffersize 16 chan puts -nonewline $f "abcdefghijklmno\r" @@ -1423,7 +1416,7 @@ test chan-io-13.2 {TranslateInputEOL: crlf mode} -body { chan close $f } -result "abcd\ndef\n" test chan-io-13.3 {TranslateInputEOL: crlf mode: naked cr} -body { - # (src >= srcMax) + # (src >= srcMax) set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\r\ndef\r" @@ -1435,7 +1428,7 @@ test chan-io-13.3 {TranslateInputEOL: crlf mode: naked cr} -body { chan close $f } -result "abcd\ndef\r" test chan-io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} -body { - # (src >= srcMax) + # (src >= srcMax) set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\r\ndef\rfgh" @@ -1447,7 +1440,7 @@ test chan-io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} -body { chan close $f } -result "abcd\ndef\rfgh" test chan-io-13.5 {TranslateInputEOL: crlf mode: naked lf} -body { - # (src >= srcMax) + # (src >= srcMax) set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\r\ndef\nfgh" @@ -1515,7 +1508,7 @@ test chan-io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} -body { chan close $f } -result "abcd\ndef" test chan-io-13.10 {TranslateInputEOL: auto mode: \n} -body { - # not (*src == '\r') + # not (*src == '\r') set f [open $path(test1) w] chan configure $f -translation lf chan puts -nonewline $f "abcd\ndef" @@ -3901,7 +3894,7 @@ test chan-io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} -setup { } chan close $f set f [open $path(test1) r] - chan configure $f -translation crlf + chan configure $f -translation crlf while {[chan gets $f line] >= 0} { append c $line\n } @@ -5163,7 +5156,7 @@ test chan-io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} -setup { file delete $path(test1) } -body { set f [open $path(test1) w] - chan configure $f -encoding {} + chan configure $f -encoding {} chan puts -nonewline $f \xe7\x89\xa6 chan close $f set f [open $path(test1) r] @@ -5308,7 +5301,7 @@ test chan-io-39.23 {Tcl_GetChannelOption, server socket is not readable or\ test chan-io-39.24 {Tcl_SetChannelOption, server socket is not readable or\ writable so we can't change -eofchar or -translation} -setup { set l [list] -} -body { +} -body { set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0] chan configure $sock -eofchar D -translation lf lappend l [chan configure $sock -eofchar] \ @@ -5345,7 +5338,7 @@ test chan-io-40.2 {POSIX open access modes: CREAT} -setup { lappend x [chan gets $f] } -cleanup { chan close $f -} -result {0600 {line 1}} +} -result {0o600 {line 1}} test chan-io-40.3 {POSIX open access modes: CREAT} -setup { file delete $path(test3) } -constraints {unix umask} -body { @@ -5353,7 +5346,7 @@ test chan-io-40.3 {POSIX open access modes: CREAT} -setup { chan close [open $path(test3) {WRONLY CREAT}] file stat $path(test3) stats format "%#o" [expr $stats(mode)&0o777] -} -result [format %#4o [expr {0o666 & ~ $umaskValue}]] +} -result [format %#5o [expr {0o666 & ~ $umaskValue}]] test chan-io-40.4 {POSIX open access modes: CREAT} -setup { file delete $path(test3) } -body { @@ -5461,7 +5454,7 @@ test chan-io-40.13 {POSIX open access modes: WRONLY} -body { set x [list [catch {chan gets $f} msg] $msg] chan close $f lappend x [viewFile test3] -} -match glob -result {1 {channel "*" wasn't opened for reading} abzzy} +} -match glob -result {1 {channel "*" wasn't opened for reading} abzzy} test chan-io-40.14 {POSIX open access modes: RDWR} -match regexp -body { file delete $path(test3) open $path(test3) RDWR @@ -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/cmdIL.test b/tests/cmdIL.test index 23a5f96..360d6b0 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -147,6 +147,24 @@ test cmdIL-1.36 {lsort -stride and -index: Bug 2918962} { {{b i g} 12345} {{d e m o} 34512} } } {{{b i g} 12345} {{d e m o} 34512} {{c o d e} 54321} {{b l a h} 94729}} +test cmdIL-1.37 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { + lsort -ascii [list \0 \x7f \x80 \uffff] +} [list \0 \x7f \x80 \uffff] +test cmdIL-1.38 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { + lsort -ascii -nocase [list \0 \x7f \x80 \uffff] +} [list \0 \x7f \x80 \uffff] +test cmdIL-1.39 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { + lsort -ascii [list \0 \x7f \x80 \U01ffff \uffff] +} [list \0 \x7f \x80 \uffff \U01ffff] +test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} { + lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff] +} [list \0 \x7f \x80 \uffff \U01ffff] +test cmdIL-1.41 {lsort -stride and -index} -body { + lsort -stride 2 -index -2 {a 2 b 1} +} -returnCodes error -result {index "-2" cannot select an element from any list} +test cmdIL-1.42 {lsort -stride and-index} -body { + lsort -stride 2 -index -1-1 {a 2 b 1} +} -returnCodes error -result {index "-1-1" cannot select an element from any list} # Can't think of any good tests for the MergeSort and MergeLists procedures, # except a bunch of random lists to sort. @@ -203,6 +221,33 @@ test cmdIL-3.4.1 {SortCompare procedure, -index option} -body { test cmdIL-3.5 {SortCompare procedure, -index option} -body { lsort -integer -index 2 {{20 10 13} {15}} } -returnCodes error -result {element 2 missing from sublist "15"} +test cmdIL-3.5.1 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index 1+3 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {element 4 missing from sublist "1 . c"} +test cmdIL-3.5.2 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index -1-1 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {index "-1-1" cannot select an element from any list} +test cmdIL-3.5.3 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index -2 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {index "-2" cannot select an element from any list} +test cmdIL-3.5.4 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index end-4 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {element -2 missing from sublist "1 . c"} +test cmdIL-3.5.5 {SortCompare procedure, -index option} { + lsort -index {} {a b} +} {a b} +test cmdIL-3.5.6 {SortCompare procedure, -index option} { + lsort -index {} [list a \{] +} {a \{} +test cmdIL-3.5.7 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index end--1 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {index "end--1" cannot select an element from any list} +test cmdIL-3.5.8 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index end+1 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {index "end+1" cannot select an element from any list} +test cmdIL-3.5.9 {SortCompare procedure, -index option (out of range, calculated index)} -body { + lsort -index end+2 {{1 . c} {2 . b} {3 . a}} +} -returnCodes error -result {index "end+2" cannot select an element from any list} test cmdIL-3.6 {SortCompare procedure, -index option} { lsort -integer -index 2 {{1 15 30} {2 5 25} {3 25 20}} } {{3 25 20} {2 5 25} {1 15 30}} @@ -219,8 +264,8 @@ test cmdIL-3.10 {SortCompare procedure, -integer option} -body { lsort -integer {3 q} } -returnCodes error -result {expected integer but got "q"} test cmdIL-3.11 {SortCompare procedure, -integer option} { - lsort -integer {35 21 0x20 30 0o23 100 8} -} {8 0o23 21 30 0x20 35 100} + lsort -integer {35 21 0x20 0d30 0o23 100 8} +} {8 0o23 21 0d30 0x20 35 100} test cmdIL-3.12 {SortCompare procedure, -real option} -body { lsort -real {6...4 3} } -returnCodes error -result {expected floating-point number but got "6...4"} diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index 2d68138..a5f3009 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -234,7 +234,7 @@ test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints { test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints { unixOrPc } -returnCodes error -body { - source a b + source a b c d e f } -match glob -result {wrong # args: should be "source*fileName"} test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body { set file [makeFile { diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test index bae26a0..e57f799 100644 --- a/tests/compExpr-old.test +++ b/tests/compExpr-old.test @@ -20,12 +20,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { - testConstraint testmathfunctions 0 -} else { - testConstraint testmathfunctions 1 -} - # Big test for correct ordering of data in [expr] proc testIEEE {} { @@ -84,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 @@ -337,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 @@ -602,22 +589,6 @@ test compExpr-old-15.5 {CompileMathFuncCall: too few arguments} -body { test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body { expr sin(1 } -returnCodes error -match glob -result * -test compExpr-old-15.7 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr 2*T1() -} 246 -test compExpr-old-15.8 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T2()*3 -} 1035 -test compExpr-old-15.9 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T3(21, 37) -} 37 -test compExpr-old-15.10 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T3(21.2, 37) -} 37.0 -test compExpr-old-15.11 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T3(-21.2, -17.5) -} -17.5 - test compExpr-old-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} { catch {unset a} set a(VALUE) ff15 diff --git a/tests/compExpr.test b/tests/compExpr.test index 14c875d..3b44af8 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -16,12 +16,6 @@ if {"::tcltest" ni [namespace children]} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { - testConstraint testmathfunctions 0 -} else { - testConstraint testmathfunctions 1 -} - # Constrain memory leak tests testConstraint memory [llength [info commands memory]] @@ -319,12 +313,6 @@ test compExpr-5.1 {CompileMathFuncCall procedure, math function found} { test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} -body { expr {do_it()} } -returnCodes error -match glob -result {* "*do_it"} -test compExpr-5.3 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr 3*T1()-1 -} 368 -test compExpr-5.4 {CompileMathFuncCall: call registered math function} testmathfunctions { - expr T2()*3 -} 1035 test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} -body { expr {atan2(1.0)} } -returnCodes error -match glob -result {too few arguments for math function*} diff --git a/tests/compile.test b/tests/compile.test index f021cf2..fb9a87a 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -122,7 +122,7 @@ test compile-3.4 {TclCompileCatchCmd: bcc'ed [return] is caught} { proc foo {} { set fail [catch { return 1 - }] ; # {} + }] ; # {} return 2 } foo @@ -132,8 +132,8 @@ test compile-3.5 {TclCompileCatchCmd: recover from error, [Bug 705406]} { catch { if {[a]} { if b {} - } - } + } + } } list [catch foo msg] $msg } {0 1} @@ -344,13 +344,13 @@ test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { list [catch {p} msg] $msg } -returnCodes error -result {unmatched open brace in list} -# +# # Special section for tests of tclLiteral.c # The following tests check for incorrect memory handling in # TclReleaseLiteral. They are only effective when tcl is compiled with # TCL_MEM_DEBUG # -# Special test for leak on interp delete [Bug 467523]. +# Special test for leak on interp delete [Bug 467523]. test compile-12.1 {testing literal leak on interp delete} -setup { proc getbytes {} { set lines [split [memory info] "\n"] @@ -359,10 +359,10 @@ test compile-12.1 {testing literal leak on interp delete} -setup { } -constraints memory -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { - interp create foo - foo eval { + interp create foo + foo eval { namespace eval bar {} - } + } interp delete foo set tmp $end set end [getbytes] @@ -383,7 +383,7 @@ test compile-12.2 {testing error on literal deletion} -constraints {memory exec} } puts 0 } source.file] - exec [interpreter] $sourceFile + exec [interpreter] $sourceFile } -cleanup { catch {removeFile $sourceFile} } -result 0 @@ -476,7 +476,7 @@ test compile-14.1 {testing errors in element name; segfault?} {} { test compile-14.2 {testing element name "$"} -body { unset -nocomplain a set a() 1 - set a(1) 2 + set a(1) 2 set a($) 3 list [set a()] [set a(1)] [set a($)] [unset a() a(1); lindex [array names a] 0] } -cleanup {unset a} -result [list 1 2 3 {$}] @@ -499,7 +499,8 @@ test compile-15.5 {proper TCL_RETURN code from [return]} { apply {{} {catch {set a 1}; return}} } "" -for {set noComp 0} {$noComp <= 1} {incr noComp} { +# Do all tests once byte compiled and once with direct string evaluation +foreach noComp {0 1} { if $noComp { interp alias {} run {} testevalex 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/coroutine.test b/tests/coroutine.test index fd68567..8217a92 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -66,7 +66,7 @@ test coroutine-1.3 {yield returns new arg} -setup { incr i } } - coroutine foo ::apply [list {{start 2} {stop 10}} $body] + coroutine foo ::apply [list {{start 2} {stop 10}} $body] set res {} } -body { for {set k 1} {$k < 4} {incr k} { @@ -476,7 +476,7 @@ test coroutine-5.1 {right numLevels on coro return} -constraints {testnrelevels} expr {[lindex [testnrelevels] 1] - 1} } proc relativeLevel base { - # remove the level for this proc's call + # remove the level for this proc's call expr {[getNumLevel] - $base - 1} } proc foo {} { @@ -517,7 +517,7 @@ test coroutine-5.2 {right numLevels within coro} -constraints {testnrelevels} \ expr {[lindex [testnrelevels] 1] - 1} } proc relativeLevel base { - # remove the level for this proc's call + # remove the level for this proc's call expr {[getNumLevel] - $base - 1} } proc foo base { @@ -588,7 +588,7 @@ test coroutine-7.2 {multi-argument yielding with yieldto} -body { coroutine a corobody coroutine b corobody list [a x] [a y z] [a \{p] [a \{q r] [a] [a] [rename a {}] \ - [b ok] [rename b {}] + [b ok] [rename b {}] } -cleanup { rename corobody {} } -result {x {y z 2} \{p {\{q r 2} {} 0 {} ok {}} @@ -739,6 +739,8 @@ test coroutine-7.12 {coro floor above street level #3008307} -body { } boom ; # does not crash: the coro floor is a good insulator list +} -cleanup { + rename boom {}; rename cc {}; rename c {} } -result {} test coroutine-8.0.0 {coro inject executed} -body { diff --git a/tests/dict.test b/tests/dict.test index a6b0cb4..904ec53 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -10,7 +10,7 @@ # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } @@ -175,11 +175,7 @@ test dict-4.12 {dict replace command: canonicality is forced} { } {a e c d} test dict-4.13 {dict replace command: type check is mandatory} -body { dict replace { a b c d e } -} -returnCodes error -result {missing value to go with key} -test dict-4.13a {dict replace command: type check is mandatory} { - catch {dict replace { a b c d e }} -> opt - dict get $opt -errorcode -} {TCL VALUE DICTIONARY} +} -errorCode {TCL VALUE DICTIONARY} -result {missing value to go with key} test dict-4.14 {dict replace command: type check is mandatory} -body { dict replace { a b {}c d } } -returnCodes error -result {dict element in braces followed by "c" instead of space} @@ -203,11 +199,7 @@ test dict-4.16a {dict replace command: type check is mandatory} { } {TCL VALUE DICTIONARY QUOTE} test dict-4.17 {dict replace command: type check is mandatory} -body { dict replace " a b \{c d " -} -returnCodes error -result {unmatched open brace in dict} -test dict-4.17a {dict replace command: type check is mandatory} { - catch {dict replace " a b \{c d "} -> opt - dict get $opt -errorcode -} {TCL VALUE DICTIONARY BRACE} +} -errorCode {TCL VALUE DICTIONARY BRACE} -result {unmatched open brace in dict} test dict-4.18 {dict replace command: canonicality forcing doesn't leak} { set example { a b c d } list $example [dict replace $example] diff --git a/tests/encoding.test b/tests/encoding.test index ed0e6a4..ab60617 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -34,9 +34,11 @@ proc runtests {} { # Some tests require the testencoding command testConstraint testencoding [llength [info commands testencoding]] -testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}] +testConstraint testbytestring [llength [info commands testbytestring]] +testConstraint teststringbytes [llength [info commands teststringbytes]] +testConstraint tip389 [expr {[string length \U010000] == 2}] testConstraint exec [llength [info commands exec]] -testConstraint testgetdefenc [llength [info commands testgetdefenc]] +testConstraint testgetencpath [llength [info commands testgetencpath]] # TclInitEncodingSubsystem is tested by the rest of this file # TclFinalizeEncodingSubsystem is not currently tested @@ -308,37 +310,29 @@ test encoding-13.1 {LoadEscapeTable} { viewable [set x [encoding convertto iso2022 ab\u4e4e\u68d9g]] } [viewable "ab\x1b\$B8C\x1b\$\(DD%\x1b(Bg"] -test encoding-14.1 {BinaryProc} { - encoding convertto identity \x12\x34\x56\xff\x69 -} "\x12\x34\x56\xc3\xbf\x69" - test encoding-15.1 {UtfToUtfProc} { encoding convertto utf-8 \xa3 } "\xc2\xa3" -test encoding-15.2 {UtfToUtfProc null character output} { - set x \u0000 - set y [encoding convertto utf-8 \u0000] - set y [encoding convertfrom identity $y] - binary scan $y H* z - list [string bytelength $x] [string bytelength $y] $z -} {2 1 00} -test encoding-15.3 {UtfToUtfProc null character input} { - set x [encoding convertfrom identity \x00] - set y [encoding convertfrom utf-8 $x] - binary scan [encoding convertto identity $y] H* z - list [string bytelength $x] [string bytelength $y] $z -} {1 2 c080} - -test encoding-16.1 {UnicodeToUtfProc} { +test encoding-15.2 {UtfToUtfProc null character output} testbytestring { + binary scan [testbytestring [encoding convertto utf-8 \u0000]] H* z + set z +} 00 +test encoding-15.3 {UtfToUtfProc null character input} teststringbytes { + set y [encoding convertfrom utf-8 [encoding convertto utf-8 \u0000]] + binary scan [teststringbytes $y] H* z + set z +} c080 + +test encoding-16.1 {UnicodeToUtfProc} -constraints tip389 -body { set val [encoding convertfrom unicode NN] list $val [format %x [scan $val %c]] -} "\u4e4e 4e4e" -test encoding-16.2 {UnicodeToUtfProc} -constraints fullutf -body { +} -result "\u4e4e 4e4e" +test encoding-16.2 {UnicodeToUtfProc} -constraints tip389 -body { set val [encoding convertfrom unicode "\xd8\xd8\xdc\xdc"] list $val [format %x [scan $val %c]] } -result "\U460dc 460dc" -test encoding-17.1 {UtfToUnicodeProc} -constraints fullutf -body { +test encoding-17.1 {UtfToUnicodeProc} -constraints tip389 -body { encoding convertto unicode "\U460dc" } -result "\xd8\xd8\xdc\xdc" @@ -601,15 +595,15 @@ foreach from {cp932 shiftjis euc-jp iso2022-jp} { } } -test encoding-26.0 {Tcl_GetDefaultEncodingDir} -constraints { - testgetdefenc +test encoding-26.0 {Tcl_GetEncodingSearchPath} -constraints { + testgetencpath } -setup { - set origDir [testgetdefenc] - testsetdefenc slappy + set origPath [testgetencpath] + testsetencpath slappy } -body { - testgetdefenc + testgetencpath } -cleanup { - testsetdefenc $origDir + testsetencpath $origPath } -result slappy file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout] 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/event.test b/tests/event.test index 207c799..ef0947f 100644 --- a/tests/event.test +++ b/tests/event.test @@ -595,16 +595,16 @@ test event-11.7 {Bug 16828b3744} { test event-11.8 {Bug 16828b3744} -setup { oo::class create A { variable continue - + method start {} { after idle [self] destroy - + set continue 0 vwait [namespace current]::continue } destructor { set continue 1 - } + } } } -body { [A new] start diff --git a/tests/exec.test b/tests/exec.test index 5542f3d..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 @@ -698,9 +705,6 @@ test exec-20.1 {exec .CMD file} -constraints {win} -body { exec [makeFile "echo %1> $log" exec201.CMD] "Testing exec-20.1" viewFile $log } -result "\"Testing exec-20.1\"" - - - # ---------------------------------------------------------------------- # cleanup diff --git a/tests/execute.test b/tests/execute.test index e1ed68b..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: @@ -698,7 +698,7 @@ test execute-6.12 {Tcl_ExprObj: exprcode interp validation} -setup { lappend result [e $e] interp delete slave interp create slave - interp alias {} e slave expr + interp alias {} e slave expr lappend result [e $e] } -cleanup { interp delete slave @@ -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 @@ -1013,8 +1013,8 @@ test execute-10.3 {Bug 3072640} -setup { yield $i } } - proc t {args} { - incr ::foo + proc t {args} { + incr ::foo } trace add execution ::generate enterstep ::t } -body { diff --git a/tests/expr-old.test b/tests/expr-old.test index 06a00ba..003ee00 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -22,13 +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}] - -if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} { - testConstraint testmathfunctions 0 -} else { - testConstraint testmathfunctions 1 -} +testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}] +testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}] # Big test for correct ordering of data in [expr] @@ -420,13 +415,13 @@ test expr-old-21.3 {parenthesization} {expr +(3-4)} -1 # Embedded commands and variable names. -set a 16 -test expr-old-22.1 {embedded variables} {expr {2*$a}} 32 +set a 16 +test expr-old-22.1 {embedded variables} {expr {2*$a}} 32 test expr-old-22.2 {embedded variables} { set x -5 set y 10 expr {$x + $y} -} {5} +} {5} test expr-old-22.3 {embedded variables} { set x " -5" set y " +10" @@ -819,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} @@ -847,12 +842,6 @@ test expr-old-32.41 {math functions in expressions} { test expr-old-32.42 {math functions in expressions} { list [catch {expr hypot(5*.8,3)} msg] $msg } {0 5.0} -test expr-old-32.43 {math functions in expressions} testmathfunctions { - expr 2*T1() -} 246 -test expr-old-32.44 {math functions in expressions} testmathfunctions { - expr T2()*3 -} 1035 test expr-old-32.45 {math functions in expressions} { expr (0 <= rand()) && (rand() < 1) } {1} @@ -952,11 +941,6 @@ test expr-old-34.15 {errors in math functions} { test expr-old-34.16 {errors in math functions} { expr round(-1.0e30) } -1000000000000000019884624838656 -test expr-old-34.17 {errors in math functions} -constraints testmathfunctions \ - -body { - list [catch {expr T1(4)} msg] $msg - } -match glob -result {1 {too many arguments for math function*}} - test expr-old-36.1 {ExprLooksLikeInt procedure} -body { expr 0o289 } -returnCodes error -match glob -result {*invalid octal number*} @@ -1052,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 \ @@ -1077,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 \ @@ -1120,7 +1108,7 @@ test expr-old-37.25 {Tcl_ExprDouble and NaN} \ {ieeeFloatingPoint testexprdouble} { list [catch {testexprdouble 0.0/0.0} result] $result } {1 {domain error: argument not in valid range}} - + test expr-old-38.1 {Verify Tcl_ExprString's basic operation} -constraints {testexprstring} -body { list [testexprstring "1+4"] [testexprstring "2*3+4.2"] \ [catch {testexprstring "1+"} msg] $msg @@ -1159,8 +1147,8 @@ test expr-old-40.2 {min math function} -body { expr {min(0.0)} } -result 0.0 test expr-old-40.3 {min math function} -body { - list [catch {expr {min()}} msg] $msg -} -result {1 {too few arguments to math function "min"}} + expr {min()} +} -returnCodes error -result {too few arguments for math function "min"} test expr-old-40.4 {min math function} -body { expr {min(wide(-1) << 30, 4.5, -10)} } -result [expr {wide(-1) << 30}] @@ -1170,6 +1158,12 @@ test expr-old-40.5 {min math function} -body { test expr-old-40.6 {min math function} -body { expr {min(300, "0xFF")} } -result 255 +test expr-old-40.7 {min math function} -body { + expr min(1[string repeat 0 10000], 1e300) +} -result 1e+300 +test expr-old-40.8 {min math function} -body { + expr {min(0, "a")} +} -returnCodes error -match glob -result * test expr-old-41.1 {max math function} -body { expr {max(0)} @@ -1178,8 +1172,8 @@ test expr-old-41.2 {max math function} -body { expr {max(0.0)} } -result 0.0 test expr-old-41.3 {max math function} -body { - list [catch {expr {max()}} msg] $msg -} -result {1 {too few arguments to math function "max"}} + expr {max()} +} -returnCodes error -result {too few arguments for math function "max"} test expr-old-41.4 {max math function} -body { expr {max(wide(1) << 30, 4.5, -10)} } -result [expr {wide(1) << 30}] @@ -1189,6 +1183,12 @@ test expr-old-41.5 {max math function} -body { test expr-old-41.6 {max math function} -body { expr {max(200, "0xFF")} } -result 255 +test expr-old-41.7 {max math function} -body { + expr max(1[string repeat 0 10000], 1e300) +} -result 1[string repeat 0 10000] +test expr-old-41.8 {max math function} -body { + expr {max(0, "a")} +} -returnCodes error -match glob -result * # Special test for Pentium arithmetic bug of 1994: diff --git a/tests/expr.test b/tests/expr.test index 5843b49..7136afc 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -18,17 +18,12 @@ if {[lsearch [namespace children] ::tcltest] == -1} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] -testConstraint testmathfunctions [expr { - ([catch {expr T1()} msg] != 1) || ($msg ne {invalid command name "tcl::mathfunc::T1"}) -}] - # 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] @@ -421,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 * @@ -685,41 +677,6 @@ test expr-15.5 {CompileMathFuncCall: too few arguments} -body { test expr-15.6 {CompileMathFuncCall: missing ')'} -body { expr sin(1 } -returnCodes error -match glob -result * -test expr-15.7 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr 2*T1() -} 246 -test expr-15.8 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr T2()*3 -} 1035 -test expr-15.9 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr T3(21, 37) -} 37 -test expr-15.10 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr T3(21.2, 37) -} 37.0 -test expr-15.11 {CompileMathFuncCall: call registered math function} {testmathfunctions} { - expr T3(-21.2, -17.5) -} -17.5 -test expr-15.12 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(21, wide(37)) -} 37 -test expr=15.13 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(wide(21), 37) -} 37 -test expr=15.14 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(wide(21), wide(37)) -} 37 -test expr-15.15 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(21.0, wide(37)) -} 37.0 -test expr-15.16 {ExprCallMathFunc: call registered math function} {testmathfunctions} { - expr T3(wide(21), 37.0) -} 37.0 -test expr-15.17 {ExprCallMathFunc: non-numeric arg} -constraints { - testmathfunctions -} -body { - expr T3(0,"a") -} -returnCodes error -result {argument to math function didn't have numeric value} test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} { @@ -1438,14 +1395,14 @@ test expr-23.74.3 {INST_EXPON: Bug 2798543} { expr {(-14)**17 == (-14)**65553} } 0 - + # Some compilers get this wrong; ensure that we work around it correctly 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 @@ -5786,7 +5743,7 @@ test expr-32.1 {expr mod basics} { 0 1 0 3 3 \ 0 -1 0 -1 -2 \ ] - + test expr-32.2 {expr div basics} { set mod_nums [list \ {-3 1} {-3 2} {-3 3} {-3 4} {-3 5} \ @@ -5838,8 +5795,17 @@ test expr-32.5 {Bug 1585704} { test expr-32.6 {Bug 1585704} { expr -(1<<32)%(1<<63) } [expr (1<<63)-(1<<32)] +test expr-32.7 {bignum regression} { + expr {0%(1<<63)} +} 0 +test expr-32.8 {bignum regression} { + expr {0%-(1<<63)} +} 0 +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 " @@ -5853,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 { @@ -5873,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 { @@ -5953,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} @@ -6750,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 \ @@ -6776,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 \ @@ -6785,7 +6751,7 @@ test expr-39.16 {Tcl_ExprLongObj handles overflows} \ list [catch {testexprlongobj 4294967296.} result] $result } \ -result {1 {integer value too large to represent*}} - + test expr-39.17 {Check that Tcl_ExprDoubleObj doesn't modify interpreter result if no error} testexprdoubleobj { testexprdoubleobj 4.+1. } {This is a result: 5.0} @@ -7187,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 c8264b2..87134d2 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -23,7 +23,7 @@ cd [temporaryDirectory] testConstraint testsetplatform [llength [info commands testsetplatform]] testConstraint testchmod [llength [info commands testchmod]] testConstraint winVista 0 -testConstraint win2000orXP 0 +testConstraint winXP 0 # Don't know how to determine this constraint correctly testConstraint notNetworkFilesystem 0 testConstraint reg 0 @@ -65,20 +65,17 @@ if {[testConstraint unix]} { # Also used in winFCmd... if {[testConstraint win]} { - set major [string index $tcl_platform(osVersion) 0] - if {[testConstraint nt] && $major > 4} { - if {$major > 5} { - testConstraint winVista 1 - } elseif {$major == 5} { - testConstraint win2000orXP 1 - } + if {$::tcl_platform(osVersion) >= 5.0} { + testConstraint winVista 1 + } else { + testConstraint winXP 1 } } 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]}] @@ -792,7 +789,7 @@ test fCmd-9.3 {file rename: comprehensive: file to new name} -setup { } -result {{tf3 tf4} 1 0} test fCmd-9.4.a {file rename: comprehensive: dir to new name} -setup { cleanup -} -constraints {win win2000orXP testchmod} -body { +} -constraints {win testchmod} -body { file mkdir td1 td2 testchmod 0o555 td2 file rename td1 td3 @@ -824,7 +821,7 @@ test fCmd-9.5 {file rename: comprehensive: file to self} -setup { } -result {tf1 tf2 1 0} test fCmd-9.6.a {file rename: comprehensive: dir to self} -setup { cleanup -} -constraints {win win2000orXP testchmod} -body { +} -constraints {win winXP testchmod} -body { file mkdir td1 file mkdir td2 testchmod 0o555 td2 @@ -2309,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 ce89623..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 } @@ -778,6 +778,8 @@ test filename-11.16 {Tcl_GlobCmd} { } {globTest} set globname "globTest" set horribleglobname "glob\[\{Test" +set tildeglobname "./~test.txt" + test filename-11.17 {Tcl_GlobCmd} {unix} { lsort [glob -directory $globname *] } [lsort [list [file join $globname a1] [file join $globname a2]\ @@ -917,11 +919,12 @@ test filename-11.21.1 {Tcl_GlobCmd} -body { } -result {{[tcl].testremains}} # Get rid of file/dir if it exists, since it will have been left behind by a # previous failed run. -if {[file exists $horribleglobname]} { - file delete -force $horribleglobname -} +file delete -force $horribleglobname file rename globTest $horribleglobname set globname $horribleglobname +file delete -force $tildeglobname +close [open $tildeglobname w] + test filename-11.22 {Tcl_GlobCmd} {unix} { lsort [glob -dir $globname *] } [lsort [list [file join $globname a1] [file join $globname a2]\ @@ -1040,7 +1043,9 @@ test filename-11.41 {Tcl_GlobCmd} -body { test filename-11.42 {Tcl_GlobCmd} -body { set res [list] foreach f [glob -dir [pwd] *] { - lappend res [file tail $f] + set f [file tail $f] + regsub {^./} $f {} f; # until glob bug [2511011fff] don't fixed (tilde expansion prevention). + lappend res $f } list $res [glob *] } -match compareWords -result equal @@ -1080,8 +1085,9 @@ test filename-11.49 {Tcl_GlobCmd} -returnCodes error -body { } -result {bad argument to "-types": abcde} file rename $horribleglobname globTest +file delete -force $tildeglobname set globname globTest -unset horribleglobname +unset horribleglobname tildeglobname test filename-12.1 {simple globbing} {unixOrPc} { glob {} diff --git a/tests/fileSystem.test b/tests/fileSystem.test index b805780..2494cb4 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -146,7 +146,7 @@ test filesystem-1.10 {link normalisation: double link} -constraints { [file normalize [file join dir2.link inside.file foo]] } -cleanup { file delete dir2.link -} -result ok +} -result ok makeDirectory dir2.file test filesystem-1.11 {link normalisation: double link, back in tree} {unix hasLinks} { file link dir2.link dir.link @@ -264,6 +264,12 @@ removeDirectory dir.dir test filesystem-1.30 {normalisation of nonexistent user} -body { file normalize ~noonewiththisname } -returnCodes error -result {user "noonewiththisname" doesn't exist} +test filesystem-1.30.1 {normalisation of existing user} -body { + catch {file normalize ~$::tcl_platform(user)} +} -result {0} +test filesystem-1.30.2 {normalisation of nonexistent user specified as user@domain} -body { + file normalize ~nonexistentuser@nonexistentdomain +} -returnCodes error -result {user "nonexistentuser@nonexistentdomain" doesn't exist} test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} { testsetplatform unix file normalize /foo/../bar @@ -900,7 +906,7 @@ test filesystem-9.5 {path objects and file tail and object rep} -setup { } return $res } -cleanup { - file delete -force dgp + file delete -force dgp cd $origdir } -result {test test} test filesystem-9.6 {path objects and file tail and object rep} win { diff --git a/tests/for.test b/tests/for.test index 1a65274..c8a8187 100644 --- a/tests/for.test +++ b/tests/for.test @@ -303,35 +303,35 @@ proc formatMail {} { 16 {This page contains information about Tcl 7.6 and Tk4.2, which are the most recent} \ 17 {releases of the Tcl scripting language and the Tk toolkit. The first beta versions of these} \ 18 {releases were released on August 30, 1996. These releases contain only minor changes,} \ - 19 {so we hope to have only a single beta release and to go final in early October, 1996. } \ + 19 {so we hope to have only a single beta release and to go final in early October, 1996.} \ 20 {} \ 21 {} \ - 22 {What's new } \ + 22 {What's new} \ 23 {} \ 24 {The most important changes in the releases are summarized below. See the README} \ 25 {and changes files in the distributions for more complete information on what has} \ - 26 {changed, including both feature changes and bug fixes. } \ + 26 {changed, including both feature changes and bug fixes.} \ 27 {} \ 28 { There are new options to the file command for copying files (file copy),} \ 29 { deleting files and directories (file delete), creating directories (file} \ - 30 { mkdir), and renaming files (file rename). } \ + 30 { mkdir), and renaming files (file rename).} \ 31 { The implementation of exec has been improved greatly for Windows 95 and} \ - 32 { Windows NT. } \ + 32 { Windows NT.} \ 33 { There is a new memory allocator for the Macintosh version, which should be} \ - 34 { more efficient than the old one. } \ + 34 { more efficient than the old one.} \ 35 { Tk's grid geometry manager has been completely rewritten. The layout} \ 36 { algorithm produces much better layouts than before, especially where rows or} \ - 37 { columns were stretchable. } \ + 37 { columns were stretchable.} \ 38 { There are new commands for creating common dialog boxes:} \ 39 { tk_chooseColor, tk_getOpenFile, tk_getSaveFile and} \ - 40 { tk_messageBox. These use native dialog boxes if they are available. } \ + 40 { tk_messageBox. These use native dialog boxes if they are available.} \ 41 { There is a new virtual event mechanism for handling events in a more portable} \ 42 { way. See the new command event. It also allows events (both physical and} \ - 43 { virtual) to be generated dynamically. } \ + 43 { virtual) to be generated dynamically.} \ 44 {} \ 45 {Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl 7.5 and Tk 4.1 except for} \ 46 {changes in the C APIs for custom channel drivers. Scripts written for earlier releases} \ - 47 {should work on these new releases as well. } \ + 47 {should work on these new releases as well.} \ 48 {} \ 49 {Obtaining The Releases} \ 50 {} \ @@ -342,7 +342,7 @@ proc formatMail {} { 55 { Windows 3.1, Windows 95, and Windows NT: Fetch} \ 56 { ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then execute it. The file is a} \ 57 { self-extracting executable. It will install the Tcl and Tk libraries, the wish and} \ - 58 { tclsh programs, and documentation. } \ + 58 { tclsh programs, and documentation.} \ 59 { Macintosh (both 68K and PowerPC): Fetch} \ 60 { ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx. The file is in binhex format,} \ 61 { which is understood by Fetch, StuffIt, and many other Mac utilities. The} \ @@ -451,7 +451,7 @@ proc formatMail {} { set c [string length $line] } } - set newline [string range $line 0 $c] + set newline [string trimright [string range $line 0 $c]] if {! $continuation} { append result $newline $NL } else { @@ -507,76 +507,76 @@ releases of the Tcl scripting language and the Tk toolk it. The first beta versions of these releases were released on August 30, 1996. These releas es contain only minor changes, -so we hope to have only a single beta release and to +so we hope to have only a single beta release and to go final in early October, 1996. -What's new +What's new The most important changes in the releases are summariz ed below. See the README and changes files in the distributions for more complet e information on what has -changed, including both feature changes and bug fixes. +changed, including both feature changes and bug fixes. - There are new options to the file command for + There are new options to the file command for copying files (file copy), - deleting files and directories (file delete), + deleting files and directories (file delete), creating directories (file - mkdir), and renaming files (file rename). + mkdir), and renaming files (file rename). The implementation of exec has been improved great ly for Windows 95 and - Windows NT. - There is a new memory allocator for the Macintosh + Windows NT. + There is a new memory allocator for the Macintosh version, which should be - more efficient than the old one. - Tk's grid geometry manager has been completely + more efficient than the old one. + Tk's grid geometry manager has been completely rewritten. The layout algorithm produces much better layouts than before , especially where rows or - columns were stretchable. - There are new commands for creating common dialog + columns were stretchable. + There are new commands for creating common dialog boxes: tk_chooseColor, tk_getOpenFile, tk_getSaveFile and - tk_messageBox. These use native dialog boxes if + tk_messageBox. These use native dialog boxes if they are available. There is a new virtual event mechanism for handlin g events in a more portable - way. See the new command event. It also allows + way. See the new command event. It also allows events (both physical and - virtual) to be generated dynamically. + virtual) to be generated dynamically. -Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl +Tcl 7.6 and Tk 4.2 are backwards-compatible with Tcl 7.5 and Tk 4.1 except for changes in the C APIs for custom channel drivers. Scrip ts written for earlier releases -should work on these new releases as well. +should work on these new releases as well. Obtaining The Releases Binary Releases -Pre-compiled releases are available for the following +Pre-compiled releases are available for the following platforms: Windows 3.1, Windows 95, and Windows NT: Fetch - ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then + ftp://ftp.sunlabs.com/pub/tcl/win42b1.exe, then execute it. The file is a - self-extracting executable. It will install the + self-extracting executable. It will install the Tcl and Tk libraries, the wish and - tclsh programs, and documentation. + tclsh programs, and documentation. Macintosh (both 68K and PowerPC): Fetch - ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx. + ftp://ftp.sunlabs.com/pub/tcl/mactk4.2b1.sea.hqx. The file is in binhex format, - which is understood by Fetch, StuffIt, and many + which is understood by Fetch, StuffIt, and many other Mac utilities. The - unpacked file is a self-installing executable: + unpacked file is a self-installing executable: double-click on it and it will create a - folder containing all that you need to run Tcl + folder containing all that you need to run Tcl and Tk. - UNIX (Solaris 2.* and SunOS, other systems + UNIX (Solaris 2.* and SunOS, other systems soon to follow). Easy to install - binary packages are now for sale at the Sun Labs + binary packages are now for sale at the Sun Labs Tcl/Tk Shop. Check it out! } diff --git a/tests/foreach.test b/tests/foreach.test index 6fd5476..84af4bd 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -212,14 +212,16 @@ test foreach-6.4 {break tests} { set msg } {wrong # args: should be "break"} # Check for bug #406709 -test foreach-6.5 {break tests} { +test foreach-6.5 {break tests} -body { proc a {} { set a 1 foreach b b {list [concat a; break]; incr a} incr a } a -} {2} +} -cleanup { + rename a {} +} -result {2} # Test for incorrect "double evaluation" semantics test foreach-7.1 {delayed substitution of body} { diff --git a/tests/format.test b/tests/format.test index 2795ac2..1bf46a1 100644 --- a/tests/format.test +++ b/tests/format.test @@ -16,18 +16,17 @@ 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} { format "%*d %d %d %d" 6 34 16923 -12 -1 } { 34 16923 -12 -1} test format-1.2 {integer formatting} { format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12 -} { 6 34 16923 -12 -1 0xe 0XC} +} { 6 34 16923 -12 -1 0xe 0xC} test format-1.3 {integer formatting} longIs32bit { format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0 } { 6 34 16923 4294967284 -1 0} @@ -53,49 +52,40 @@ test format-1.7.1 {integer formatting} longIs64bit { } { 6 22 421b fffffffffffffff4} test format-1.8 {integer formatting} longIs32bit { format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1 -} {0x0 0x6 0X22 0X421B 0xfffffff4} +} {0 0x6 0x22 0x421B 0xfffffff4} test format-1.8.1 {integer formatting} longIs64bit { format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1 -} {0x0 0x6 0X22 0X421B 0xfffffffffffffff4} +} {0 0x6 0x22 0x421B 0xfffffffffffffff4} test format-1.9 {integer formatting} longIs32bit { format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1 -} { 0x0 0x6 0x22 0x421b 0xfffffff4} +} { 0 0x6 0x22 0x421b 0xfffffff4} test format-1.9.1 {integer formatting} longIs64bit { format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1 -} { 0x0 0x6 0x22 0x421b 0xfffffffffffffff4} +} { 0 0x6 0x22 0x421b 0xfffffffffffffff4} test format-1.10 {integer formatting} longIs32bit { format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1 -} {0x0 0x6 0x22 0x421b 0xfffffff4 } +} {0 0x6 0x22 0x421b 0xfffffff4 } test format-1.10.1 {integer formatting} longIs64bit { format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1 -} {0x0 0x6 0x22 0x421b 0xfffffffffffffff4 } +} {0 0x6 0x22 0x421b 0xfffffffffffffff4 } test format-1.11 {integer formatting} longIs32bit { format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1 -} {0 06 042 041033 037777777764 } +} {0 0o6 0o42 0o41033 0o37777777764 } test format-1.11.1 {integer formatting} longIs64bit { format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1 -} {0 06 042 041033 01777777777777777777764} +} {0 0o6 0o42 0o41033 0o1777777777777777777764} test format-1.12 {integer formatting} { format "%b %#b %#b %llb" 5 0 5 [expr {2**100}] -} {101 0b0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000} -test format-1.13 {integer formatting} longIs32bit { - format "%#d %#d %#d %#d %#d" 0 6 34 16923 -12 -1 -} {0 6 34 16923 -12} -test format-1.13.1 {integer formatting} longIs64bit { - format "%#d %#d %#d %#d %#d" 0 6 34 16923 -12 -1 -} {0 6 34 16923 -12} -test format-1.14 {integer formatting} longIs32bit { - format "%#5d %#20d %#20d %#20d %#20d" 0 6 34 16923 -12 -1 -} { 0 6 34 16923 -12} -test format-1.14.1 {integer formatting} longIs64bit { - format "%#5d %#20d %#20d %#20d %#20d" 0 6 34 16923 -12 -1 -} { 0 6 34 16923 -12} -test format-1.15 {integer formatting} longIs32bit { - format "%-#5d %-#20d %-#20d %-#20d %-#20d" 0 6 34 16923 -12 -1 -} {0 6 34 16923 -12 } -test format-1.15.1 {integer formatting} longIs64bit { - format "%-#5d %-#20d %-#20d %-#20d %-#20d" 0 6 34 16923 -12 -1 -} {0 6 34 16923 -12 } +} {101 0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000} +test format-1.13 {integer formatting} { + format "%#0d %#0d %#0d %#0d %#0d" 0 6 34 16923 -12 -1 +} {0 0d6 0d34 0d16923 -0d12} +test format-1.14 {integer formatting} { + format "%#05d %#020d %#020d %#020d %#020d" 0 6 34 16923 -12 -1 +} {00000 0d000000000000000006 0d000000000000000034 0d000000000000016923 -0d00000000000000012} +test format-1.15 {integer formatting} { + format "%-#05d %-#020d %-#020d %-#020d %-#020d" 0 6 34 16923 -12 -1 +} {00000 0d000000000000000006 0d000000000000000034 0d000000000000016923 -0d00000000000000012} test format-2.1 {string formatting} { @@ -368,9 +358,9 @@ test format-8.19 {error conditions} { catch {format %q x} } 1 test format-8.20 {error conditions} { - catch {format %q x} msg + catch {format %r x} msg set msg -} {bad field specifier "q"} +} {bad field specifier "r"} test format-8.21 {error conditions} { catch {format %d} } 1 @@ -382,6 +372,26 @@ test format-8.23 {error conditions} { catch {format "%d %d" 24 xyz} msg set msg } {expected integer but got "xyz"} +# Since "%zd" and "%td" are equivalent to "%lld" in 64-bit platforms and +# equivalent to "%d" in 32-bit platforms, they are really not useful in +# scripts, therefore they are not documented. It's intended use is through +# the function Tcl_AppendPrintfToObj (et al). +test format-8.24 {Undocumented formats} -body { + format "%zd %td %d" [expr 2**30] [expr 2**30] [expr 2**30] +} -result {1073741824 1073741824 1073741824} +test format-8.25 {Undocumented formats} -constraints pointerIs64bit -body { + format "%zd %td %lld" [expr 2**33] [expr 2**33] [expr 2**33] +} -result {8589934592 8589934592 8589934592} +# Since "%p" is equivalent to "%#llx" in 64-bit platforms and equivalent +# to "%#x" in 32-bit platforms, it are really not useful in scripts, +# therefore they are not documented. It's intended use is through the +# function Tcl_AppendPrintfToObj (et al). +test format-8.26 {Undocumented formats} -body { + format "%p %#x" [expr 2**31] [expr 2**31] +} -result {0x80000000 0x80000000} +test format-8.27 {Undocumented formats} -constraints pointerIs64bit -body { + format "%p %#llx" [expr 2**33] [expr 2**33] +} -result {0x200000000 0x200000000} test format-9.1 {long result} { set a {1234567890abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ 1 2 3 4 5 6 7 8 9 0 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} @@ -535,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} { @@ -549,7 +559,7 @@ test format-17.4 {testing %l with non-integer} { } 1.000000 test format-17.5 {testing %llu with positive bignum} -body { format %llu 0xabcdef0123456789abcdef -} -returnCodes 1 -result {unsigned bignum format is invalid} +} -result 207698809136909011942886895 test format-17.6 {testing %llu with negative number} -body { format %llu -1 } -returnCodes 1 -result {unsigned bignum format is invalid} @@ -568,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}] @@ -585,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 7aa06c1..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 @@ -98,17 +98,17 @@ test get-3.2 {Tcl_GetDouble(FromObj), bad numbers} { } {0 1 0 1 1 {expected floating-point number but got "++1.0"} 1 {expected floating-point number but got "+-1.0"} 1 {expected floating-point number but got "-+1.0"} 0 -1 1 {expected floating-point number but got "--1.0"} 1 {expected floating-point number but got "- +1.0"}} # Bug 7114ac6141 test get-3.3 {tcl_GetInt with iffy numbers} testgetint { - lmap x {0 " 0" "0 " " 0 " " 0xa " " 010 " " 0o10 " " 0b10 "} { + lmap x {0 " 0" "0 " " 0 " " 0xa " " 007 " " 0o10 " " 0b10 "} { catch {testgetint 44 $x} x set x } -} {44 44 44 44 54 52 52 46} +} {44 44 44 44 54 51 52 46} test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj { - lmap x {0 0.0 " .0" ".0 " " 0e0 " "09" "- 0" "-0" "0o12" "0b10"} { + lmap x {0 0.0 " .0" ".0 " " 0e0 " "07" "- 0" "-0" "0o12" "0b10"} { catch {testdoubleobj set 1 $x} x set x } -} {0.0 0.0 0.0 0.0 0.0 {expected floating-point number but got "09" (looks like invalid octal number)} {expected floating-point number but got "- 0"} 0.0 10.0 2.0} +} {0.0 0.0 0.0 0.0 0.0 7.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0} # cleanup ::tcltest::cleanupTests diff --git a/tests/history.test b/tests/history.test index 3201ad7..9ff41f2 100644 --- a/tests/history.test +++ b/tests/history.test @@ -10,7 +10,7 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. - + if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* diff --git a/tests/http.test b/tests/http.test index 5a00cd5..cf30348 100644 --- a/tests/http.test +++ b/tests/http.test @@ -43,7 +43,6 @@ if {$::tcl_platform(os) eq "Darwin"} { set HOST [info hostname] } -set port 8010 set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" catch {unset data} @@ -62,9 +61,8 @@ catch {package require Thread 2.7-} if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { set httpthread [thread::create -preserved] thread::send $httpthread [list source $httpdFile] - thread::send $httpthread [list set port $port] thread::send $httpthread [list set bindata $bindata] - thread::send $httpthread {httpd_init $port} + thread::send $httpthread {httpd_init 0; set port} port puts "Running httpd in thread $httpthread" } else { if {![file exists $httpdFile]} { @@ -76,17 +74,15 @@ if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} { # Let the OS pick the port; that's much more flexible if {[catch {httpd_init 0} listen]} { puts "Cannot start http server, http test skipped" - unset port + catch {unset port} return - } else { - set port [lindex [fconfigure $listen -sockname] 2] } } 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 */* -cookiejar {} -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 @@ -101,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 */* -cookiejar {} -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, -cookiejar, -pipeline, -postfresh, -proxyfilter, -proxyhost, -proxyport, -repost, -urlencoding, -useragent, -zip} test http-1.6 {http::config} -setup { set oldenc [http::config -urlencoding] } -body { @@ -674,6 +670,451 @@ test http-7.4 {http::formatQuery} -setup { http::config -urlencoding $enc } -result {%3F} +package require -exact tcl::idna 1.0 + +test http-idna-1.1 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna +} -result {wrong # args: should be "::tcl::idna subcommand ?arg ...?"} +test http-idna-1.2 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna ? +} -result {unknown or ambiguous subcommand "?": must be decode, encode, puny, or version} +test http-idna-1.3 {IDNA package: basics} -body { + ::tcl::idna version +} -result 1.0 +test http-idna-1.4 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna version what +} -result {wrong # args: should be "::tcl::idna version"} +test http-idna-1.5 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny +} -result {wrong # args: should be "::tcl::idna puny subcommand ?arg ...?"} +test http-idna-1.6 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny ? +} -result {unknown or ambiguous subcommand "?": must be decode, or encode} +test http-idna-1.7 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny encode +} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"} +test http-idna-1.8 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny encode a b c +} -result {wrong # args: should be "::tcl::idna puny encode string ?case?"} +test http-idna-1.9 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny decode +} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"} +test http-idna-1.10 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna puny decode a b c +} -result {wrong # args: should be "::tcl::idna puny decode string ?case?"} +test http-idna-1.11 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna decode +} -result {wrong # args: should be "::tcl::idna decode hostname"} +test http-idna-1.12 {IDNA package: basics} -returnCodes error -body { + ::tcl::idna encode +} -result {wrong # args: should be "::tcl::idna encode hostname"} + +test http-idna-2.1 {puny encode: functional test} { + ::tcl::idna puny encode abc +} abc- +test http-idna-2.2 {puny encode: functional test} { + ::tcl::idna puny encode a\u20acb\u20acc +} abc-k50ab +test http-idna-2.3 {puny encode: functional test} { + ::tcl::idna puny encode ABC +} ABC- +test http-idna-2.4 {puny encode: functional test} { + ::tcl::idna puny encode A\u20ACB\u20ACC +} ABC-k50ab +test http-idna-2.5 {puny encode: functional test} { + ::tcl::idna puny encode ABC 0 +} abc- +test http-idna-2.6 {puny encode: functional test} { + ::tcl::idna puny encode A\u20ACB\u20ACC 0 +} abc-k50ab +test http-idna-2.7 {puny encode: functional test} { + ::tcl::idna puny encode ABC 1 +} ABC- +test http-idna-2.8 {puny encode: functional test} { + ::tcl::idna puny encode A\u20ACB\u20ACC 1 +} ABC-k50ab +test http-idna-2.9 {puny encode: functional test} { + ::tcl::idna puny encode abc 0 +} abc- +test http-idna-2.10 {puny encode: functional test} { + ::tcl::idna puny encode a\u20ACb\u20ACc 0 +} abc-k50ab +test http-idna-2.11 {puny encode: functional test} { + ::tcl::idna puny encode abc 1 +} ABC- +test http-idna-2.12 {puny encode: functional test} { + ::tcl::idna puny encode a\u20ACb\u20ACc 1 +} ABC-k50ab +test http-idna-2.13 {puny encode: edge cases} { + ::tcl::idna puny encode "" +} "" +test http-idna-2.14-A {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644 + u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F + }]] ""] +} egbpdaj6bu4bxfgehfvwxn +test http-idna-2.14-B {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587 + }]] ""] +} ihqwcrb4cv8a8dqg056pqjye +test http-idna-2.14-C {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587 + }]] ""] +} ihqwctvzc91f659drss3x8bo0yb +test http-idna-2.14-D {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074 + u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D + u+0065 u+0073 u+006B u+0079 + }]] ""] +} Proprostnemluvesky-uyb24dma41a +test http-idna-2.14-E {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8 + u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2 + u+05D1 u+05E8 u+05D9 u+05EA + }]] ""] +} 4dbcagdahymbxekheh6e0a7fei0b +test http-idna-2.14-F {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D + u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939 + u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947 + u+0939 u+0948 u+0902 + }]] ""] +} i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd +test http-idna-2.14-G {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092 + u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B + }]] ""] +} n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa +test http-idna-2.14-H {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774 + u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74 + u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C + }]] ""] +} 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c +test http-idna-2.14-I {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E + u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440 + u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A + u+0438 + }]] ""] +} b1abfaaepdrnnbgefbadotcwatmq2g4l +test http-idna-2.14-J {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070 + u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070 + u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061 + u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070 + u+0061 u+00F1 u+006F u+006C + }]] ""] +} PorqunopuedensimplementehablarenEspaol-fmd56a +test http-idna-2.14-K {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B + u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068 + u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067 + u+0056 u+0069 u+1EC7 u+0074 + }]] ""] +} TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g +test http-idna-2.14-L {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F + }]] ""] +} 3B-ww4c5e180e575a65lsy2b +test http-idna-2.14-M {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074 + u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D + u+004F u+004E u+004B u+0045 u+0059 u+0053 + }]] ""] +} -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n +test http-idna-2.14-N {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F + u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D + u+305D u+308C u+305E u+308C u+306E u+5834 u+6240 + }]] ""] +} Hello-Another-Way--fc4qua05auwb3674vfr0b +test http-idna-2.14-O {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032 + }]] ""] +} 2-u9tlzr9756bt3uc0v +test http-idna-2.14-P {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059 + u+308B u+0035 u+79D2 u+524D + }]] ""] +} MajiKoi5-783gue6qz075azm5e +test http-idna-2.14-Q {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0 + }]] ""] +} de-jg4avhby1noc0d +test http-idna-2.14-R {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode [join [subst [string map {u+ \\u} { + u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067 + }]] ""] +} d9juau41awczczp +test http-idna-2.14-S {puny encode: examples from RFC 3492} { + ::tcl::idna puny encode {-> $1.00 <-} +} {-> $1.00 <--} + +test http-idna-3.1 {puny decode: functional test} { + ::tcl::idna puny decode abc- +} abc +test http-idna-3.2 {puny decode: functional test} { + ::tcl::idna puny decode abc-k50ab +} a\u20acb\u20acc +test http-idna-3.3 {puny decode: functional test} { + ::tcl::idna puny decode ABC- +} ABC +test http-idna-3.4 {puny decode: functional test} { + ::tcl::idna puny decode ABC-k50ab +} A\u20ACB\u20ACC +test http-idna-3.5 {puny decode: functional test} { + ::tcl::idna puny decode ABC-K50AB +} A\u20ACB\u20ACC +test http-idna-3.6 {puny decode: functional test} { + ::tcl::idna puny decode abc-K50AB +} a\u20ACb\u20ACc +test http-idna-3.7 {puny decode: functional test} { + ::tcl::idna puny decode ABC- 0 +} abc +test http-idna-3.8 {puny decode: functional test} { + ::tcl::idna puny decode ABC-K50AB 0 +} a\u20ACb\u20ACc +test http-idna-3.9 {puny decode: functional test} { + ::tcl::idna puny decode ABC- 1 +} ABC +test http-idna-3.10 {puny decode: functional test} { + ::tcl::idna puny decode ABC-K50AB 1 +} A\u20ACB\u20ACC +test http-idna-3.11 {puny decode: functional test} { + ::tcl::idna puny decode abc- 0 +} abc +test http-idna-3.12 {puny decode: functional test} { + ::tcl::idna puny decode abc-k50ab 0 +} a\u20ACb\u20ACc +test http-idna-3.13 {puny decode: functional test} { + ::tcl::idna puny decode abc- 1 +} ABC +test http-idna-3.14 {puny decode: functional test} { + ::tcl::idna puny decode abc-k50ab 1 +} A\u20ACB\u20ACC +test http-idna-3.15 {puny decode: edge cases and errors} { + # Is this case actually correct? + binary encode hex [encoding convertto utf-8 [::tcl::idna puny decode abc]] +} c282c281c280 +test http-idna-3.16 {puny decode: edge cases and errors} -returnCodes error -body { + ::tcl::idna puny decode abc! +} -result {bad decode character "!"} +test http-idna-3.17 {puny decode: edge cases and errors} { + catch {::tcl::idna puny decode abc!} -> opt + dict get $opt -errorcode +} {PUNYCODE BAD_INPUT CHAR} +test http-idna-3.18 {puny decode: edge cases and errors} { + ::tcl::idna puny decode "" +} {} +# A helper so we don't get lots of crap in failures +proc hexify s {lmap c [split $s ""] {format u+%04X [scan $c %c]}} +test http-idna-3.19-A {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode egbpdaj6bu4bxfgehfvwxn] +} [list {*}{ + u+0644 u+064A u+0647 u+0645 u+0627 u+0628 u+062A u+0643 u+0644 + u+0645 u+0648 u+0634 u+0639 u+0631 u+0628 u+064A u+061F +}] +test http-idna-3.19-B {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode ihqwcrb4cv8a8dqg056pqjye] +} {u+4ED6 u+4EEC u+4E3A u+4EC0 u+4E48 u+4E0D u+8BF4 u+4E2D u+6587} +test http-idna-3.19-C {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode ihqwctvzc91f659drss3x8bo0yb] +} {u+4ED6 u+5011 u+7232 u+4EC0 u+9EBD u+4E0D u+8AAA u+4E2D u+6587} +test http-idna-3.19-D {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode Proprostnemluvesky-uyb24dma41a] +} [list {*}{ + u+0050 u+0072 u+006F u+010D u+0070 u+0072 u+006F u+0073 u+0074 + u+011B u+006E u+0065 u+006D u+006C u+0075 u+0076 u+00ED u+010D + u+0065 u+0073 u+006B u+0079 +}] +test http-idna-3.19-E {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode 4dbcagdahymbxekheh6e0a7fei0b] +} [list {*}{ + u+05DC u+05DE u+05D4 u+05D4 u+05DD u+05E4 u+05E9 u+05D5 u+05D8 + u+05DC u+05D0 u+05DE u+05D3 u+05D1 u+05E8 u+05D9 u+05DD u+05E2 + u+05D1 u+05E8 u+05D9 u+05EA +}] +test http-idna-3.19-F {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode \ + i1baa7eci9glrd9b2ae1bj0hfcgg6iyaf8o0a1dig0cd] +} [list {*}{ + u+092F u+0939 u+0932 u+094B u+0917 u+0939 u+093F u+0928 u+094D + u+0926 u+0940 u+0915 u+094D u+092F u+094B u+0902 u+0928 u+0939 + u+0940 u+0902 u+092C u+094B u+0932 u+0938 u+0915 u+0924 u+0947 + u+0939 u+0948 u+0902 +}] +test http-idna-3.19-G {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode n8jok5ay5dzabd5bym9f0cm5685rrjetr6pdxa] +} [list {*}{ + u+306A u+305C u+307F u+3093 u+306A u+65E5 u+672C u+8A9E u+3092 + u+8A71 u+3057 u+3066 u+304F u+308C u+306A u+3044 u+306E u+304B +}] +test http-idna-3.19-H {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode \ + 989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c] +} [list {*}{ + u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774 + u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74 + u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C +}] +test http-idna-3.19-I {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode b1abfaaepdrnnbgefbadotcwatmq2g4l] +} [list {*}{ + u+043F u+043E u+0447 u+0435 u+043C u+0443 u+0436 u+0435 u+043E + u+043D u+0438 u+043D u+0435 u+0433 u+043E u+0432 u+043E u+0440 + u+044F u+0442 u+043F u+043E u+0440 u+0443 u+0441 u+0441 u+043A + u+0438 +}] +test http-idna-3.19-J {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode \ + PorqunopuedensimplementehablarenEspaol-fmd56a] +} [list {*}{ + u+0050 u+006F u+0072 u+0071 u+0075 u+00E9 u+006E u+006F u+0070 + u+0075 u+0065 u+0064 u+0065 u+006E u+0073 u+0069 u+006D u+0070 + u+006C u+0065 u+006D u+0065 u+006E u+0074 u+0065 u+0068 u+0061 + u+0062 u+006C u+0061 u+0072 u+0065 u+006E u+0045 u+0073 u+0070 + u+0061 u+00F1 u+006F u+006C +}] +test http-idna-3.19-K {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode \ + TisaohkhngthchnitingVit-kjcr8268qyxafd2f1b9g] +} [list {*}{ + u+0054 u+1EA1 u+0069 u+0073 u+0061 u+006F u+0068 u+1ECD u+006B + u+0068 u+00F4 u+006E u+0067 u+0074 u+0068 u+1EC3 u+0063 u+0068 + u+1EC9 u+006E u+00F3 u+0069 u+0074 u+0069 u+1EBF u+006E u+0067 + u+0056 u+0069 u+1EC7 u+0074 +}] +test http-idna-3.19-L {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode 3B-ww4c5e180e575a65lsy2b] +} {u+0033 u+5E74 u+0042 u+7D44 u+91D1 u+516B u+5148 u+751F} +test http-idna-3.19-M {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode -with-SUPER-MONKEYS-pc58ag80a8qai00g7n9n] +} [list {*}{ + u+5B89 u+5BA4 u+5948 u+7F8E u+6075 u+002D u+0077 u+0069 u+0074 + u+0068 u+002D u+0053 u+0055 u+0050 u+0045 u+0052 u+002D u+004D + u+004F u+004E u+004B u+0045 u+0059 u+0053 +}] +test http-idna-3.19-N {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode Hello-Another-Way--fc4qua05auwb3674vfr0b] +} [list {*}{ + u+0048 u+0065 u+006C u+006C u+006F u+002D u+0041 u+006E u+006F + u+0074 u+0068 u+0065 u+0072 u+002D u+0057 u+0061 u+0079 u+002D + u+305D u+308C u+305E u+308C u+306E u+5834 u+6240 +}] +test http-idna-3.19-O {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode 2-u9tlzr9756bt3uc0v] +} {u+3072 u+3068 u+3064 u+5C4B u+6839 u+306E u+4E0B u+0032} +test http-idna-3.19-P {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode MajiKoi5-783gue6qz075azm5e] +} [list {*}{ + u+004D u+0061 u+006A u+0069 u+3067 u+004B u+006F u+0069 u+3059 + u+308B u+0035 u+79D2 u+524D +}] +test http-idna-3.19-Q {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode de-jg4avhby1noc0d] +} {u+30D1 u+30D5 u+30A3 u+30FC u+0064 u+0065 u+30EB u+30F3 u+30D0} +test http-idna-3.19-R {puny decode: examples from RFC 3492} { + hexify [::tcl::idna puny decode d9juau41awczczp] +} {u+305D u+306E u+30B9 u+30D4 u+30FC u+30C9 u+3067} +test http-idna-3.19-S {puny decode: examples from RFC 3492} { + ::tcl::idna puny decode {-> $1.00 <--} +} {-> $1.00 <-} +rename hexify "" + +test http-idna-4.1 {IDNA encoding} { + ::tcl::idna encode abc.def +} abc.def +test http-idna-4.2 {IDNA encoding} { + ::tcl::idna encode a\u20acb\u20acc.def +} xn--abc-k50ab.def +test http-idna-4.3 {IDNA encoding} { + ::tcl::idna encode def.a\u20acb\u20acc +} def.xn--abc-k50ab +test http-idna-4.4 {IDNA encoding} { + ::tcl::idna encode ABC.DEF +} ABC.DEF +test http-idna-4.5 {IDNA encoding} { + ::tcl::idna encode A\u20acB\u20acC.def +} xn--ABC-k50ab.def +test http-idna-4.6 {IDNA encoding: invalid edge case} { + # Should this be an error? + ::tcl::idna encode abc..def +} abc..def +test http-idna-4.7 {IDNA encoding: invalid char} -returnCodes error -body { + ::tcl::idna encode abc.$.def +} -result {bad character "$" in DNS name} +test http-idna-4.7.1 {IDNA encoding: invalid char} { + catch {::tcl::idna encode abc.$.def} -> opt + dict get $opt -errorcode +} {IDNA INVALID_NAME_CHARACTER {$}} +test http-idna-4.8 {IDNA encoding: empty} { + ::tcl::idna encode "" +} {} +set overlong www.[join [subst [string map {u+ \\u} { + u+C138 u+ACC4 u+C758 u+BAA8 u+B4E0 u+C0AC u+B78C u+B4E4 u+C774 + u+D55C u+AD6D u+C5B4 u+B97C u+C774 u+D574 u+D55C u+B2E4 u+BA74 + u+C5BC u+B9C8 u+B098 u+C88B u+C744 u+AE4C +}]] ""].com +test http-idna-4.9 {IDNA encoding: max lengths from RFC 5890} -body { + ::tcl::idna encode $overlong +} -returnCodes error -result "hostname part too long" +test http-idna-4.9.1 {IDNA encoding: max lengths from RFC 5890} { + catch {::tcl::idna encode $overlong} -> opt + dict get $opt -errorcode +} {IDNA OVERLONG_PART xn--989aomsvi5e83db1d2a355cv1e0vak1dwrv93d5xbh15a0dt30a5jpsd879ccm6fea98c} +unset overlong +test http-idna-4.10 {IDNA encoding: edge cases} { + ::tcl::idna encode pass\u00e9.example.com +} xn--pass-epa.example.com + +test http-idna-5.1 {IDNA decoding} { + ::tcl::idna decode abc.def +} abc.def +test http-idna-5.2 {IDNA decoding} { + # Invalid entry that's just a wrapper + ::tcl::idna decode xn--abc-.def +} abc.def +test http-idna-5.3 {IDNA decoding} { + # Invalid entry that's just a wrapper + ::tcl::idna decode xn--abc-.xn--def- +} abc.def +test http-idna-5.4 {IDNA decoding} { + # Invalid entry that's just a wrapper + ::tcl::idna decode XN--abc-.XN--def- +} abc.def +test http-idna-5.5 {IDNA decoding: error cases} -returnCodes error -body { + ::tcl::idna decode xn--$$$.example.com +} -result {bad decode character "$"} +test http-idna-5.5.1 {IDNA decoding: error cases} { + catch {::tcl::idna decode xn--$$$.example.com} -> opt + dict get $opt -errorcode +} {PUNYCODE BAD_INPUT CHAR} +test http-idna-5.6 {IDNA decoding: error cases} -returnCodes error -body { + ::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def +} -result {exceeded input data} +test http-idna-5.6.1 {IDNA decoding: error cases} { + catch {::tcl::idna decode xn--a-zzzzzzzzzzzzzzzzzzzzzzzzzzzzzz.def} -> opt + dict get $opt -errorcode +} {PUNYCODE BAD_INPUT LENGTH} + # cleanup catch {unset url} catch {unset badurl} 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/httpcookie.test b/tests/httpcookie.test new file mode 100644 index 0000000..204c263 --- /dev/null +++ b/tests/httpcookie.test @@ -0,0 +1,853 @@ +# Commands covered: http::cookiejar +# +# This file contains a collection of tests for the cookiejar package. +# Sourcing this file into Tcl runs the tests and generates output for errors. +# No output means no errors were found. +# +# Copyright (c) 2014 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 tcltest 2 +namespace import -force ::tcltest::* + +testConstraint cookiejar [expr {![catch { + package require cookiejar +}]}] + +test http-cookiejar-1.1 {cookie storage: packaging} cookiejar { + package require cookiejar +} 0.1 +test http-cookiejar-1.2 {cookie storage: packaging} cookiejar { + package require cookiejar + package require cookiejar +} 0.1 + +test http-cookiejar-2.1 {cookie storage: basics} -constraints cookiejar -body { + http::cookiejar +} -returnCodes error -result {wrong # args: should be "http::cookiejar method ?arg ...?"} +test http-cookiejar-2.2 {cookie storage: basics} -constraints cookiejar -body { + http::cookiejar ? +} -returnCodes error -result {unknown method "?": must be configure, create, destroy or new} +test http-cookiejar-2.3 {cookie storage: basics} cookiejar { + http::cookiejar configure +} {-domainfile -domainlist -domainrefresh -loglevel -offline -purgeold -retain -vacuumtrigger} +test http-cookiejar-2.4 {cookie storage: basics} -constraints cookiejar -body { + http::cookiejar configure a b c d e +} -returnCodes error -result {wrong # args: should be "http::cookiejar configure ?optionName? ?optionValue?"} +test http-cookiejar-2.5 {cookie storage: basics} -constraints cookiejar -body { + http::cookiejar configure a +} -returnCodes error -result {bad option "a": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger} +test http-cookiejar-2.6 {cookie storage: basics} -constraints cookiejar -body { + http::cookiejar configure -d +} -returnCodes error -result {ambiguous option "-d": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger} +test http-cookiejar-2.7 {cookie storage: basics} -setup { + set old [http::cookiejar configure -loglevel] +} -constraints cookiejar -body { + list [http::cookiejar configure -loglevel] \ + [http::cookiejar configure -loglevel debug] \ + [http::cookiejar configure -loglevel] \ + [http::cookiejar configure -loglevel error] \ + [http::cookiejar configure -loglevel] +} -cleanup { + http::cookiejar configure -loglevel $old +} -result {info debug debug error error} +test http-cookiejar-2.8 {cookie storage: basics} -setup { + set old [http::cookiejar configure -loglevel] +} -constraints cookiejar -body { + list [http::cookiejar configure -loglevel] \ + [http::cookiejar configure -loglevel d] \ + [http::cookiejar configure -loglevel i] \ + [http::cookiejar configure -loglevel w] \ + [http::cookiejar configure -loglevel e] +} -cleanup { + http::cookiejar configure -loglevel $old +} -result {info debug info warn error} +test http-cookiejar-2.9 {cookie storage: basics} -constraints cookiejar -body { + http::cookiejar configure -off +} -match glob -result * +test http-cookiejar-2.10 {cookie storage: basics} -setup { + set oldval [http::cookiejar configure -offline] +} -constraints cookiejar -body { + http::cookiejar configure -offline true +} -cleanup { + catch {http::cookiejar configure -offline $oldval} +} -result 1 +test http-cookiejar-2.11 {cookie storage: basics} -setup { + set oldval [http::cookiejar configure -offline] +} -constraints cookiejar -body { + http::cookiejar configure -offline nonbool +} -cleanup { + catch {http::cookiejar configure -offline $oldval} +} -returnCodes error -result {expected boolean value but got "nonbool"} +test http-cookiejar-2.12 {cookie storage: basics} -setup { + set oldval [http::cookiejar configure -purgeold] +} -constraints cookiejar -body { + http::cookiejar configure -purge nonint +} -cleanup { + catch {http::cookiejar configure -purgeold $oldval} +} -returnCodes error -result {expected positive integer but got "nonint"} +test http-cookiejar-2.13 {cookie storage: basics} -setup { + set oldval [http::cookiejar configure -domainrefresh] +} -constraints cookiejar -body { + http::cookiejar configure -domainref nonint +} -cleanup { + catch {http::cookiejar configure -domainrefresh $oldval} +} -returnCodes error -result {expected positive integer but got "nonint"} +test http-cookiejar-2.14 {cookie storage: basics} -setup { + set oldval [http::cookiejar configure -domainrefresh] +} -constraints cookiejar -body { + http::cookiejar configure -domainref -42 +} -cleanup { + catch {http::cookiejar configure -domainrefresh $oldval} +} -returnCodes error -result {expected positive integer but got "-42"} +test http-cookiejar-2.15 {cookie storage: basics} -setup { + set oldval [http::cookiejar configure -domainrefresh] + set result unset + set tracer [http::cookiejar create tracer] +} -constraints cookiejar -body { + oo::objdefine $tracer method PostponeRefresh {} { + set ::result set + next + } + http::cookiejar configure -domainref 12345 + return $result +} -cleanup { + $tracer destroy + catch {http::cookiejar configure -domainrefresh $oldval} +} -result set + +test http-cookiejar-3.1 {cookie storage: class} cookiejar { + info object isa object http::cookiejar +} 1 +test http-cookiejar-3.2 {cookie storage: class} cookiejar { + info object isa class http::cookiejar +} 1 +test http-cookiejar-3.3 {cookie storage: class} cookiejar { + lsort [info object methods http::cookiejar] +} {configure} +test http-cookiejar-3.4 {cookie storage: class} cookiejar { + lsort [info object methods http::cookiejar -all] +} {configure create destroy new} +test http-cookiejar-3.5 {cookie storage: class} -setup { + catch {rename ::cookiejar ""} +} -constraints cookiejar -body { + namespace eval :: {http::cookiejar create cookiejar} +} -cleanup { + catch {rename ::cookiejar ""} +} -result ::cookiejar +test http-cookiejar-3.6 {cookie storage: class} -setup { + catch {rename ::cookiejar ""} +} -constraints cookiejar -body { + list [http::cookiejar create ::cookiejar] [info commands ::cookiejar] \ + [::cookiejar destroy] [info commands ::cookiejar] +} -cleanup { + catch {rename ::cookiejar ""} +} -result {::cookiejar ::cookiejar {} {}} +test http-cookiejar-3.7 {cookie storage: class} -setup { + catch {rename ::cookiejar ""} +} -constraints cookiejar -body { + http::cookiejar create ::cookiejar foo bar +} -returnCodes error -cleanup { + catch {rename ::cookiejar ""} +} -result {wrong # args: should be "http::cookiejar create ::cookiejar ?path?"} +test http-cookiejar-3.8 {cookie storage: class} -setup { + catch {rename ::cookiejar ""} + set f [makeFile "" cookiejar] + file delete $f +} -constraints cookiejar -body { + http::cookiejar create ::cookiejar $f +} -cleanup { + catch {rename ::cookiejar ""} + removeFile $f +} -result ::cookiejar +test http-cookiejar-3.9 {cookie storage: class} -setup { + catch {rename ::cookiejar ""} + set f [makeFile "bogus content for a database" cookiejar] +} -constraints cookiejar -body { + http::cookiejar create ::cookiejar $f +} -returnCodes error -cleanup { + catch {rename ::cookiejar ""} + removeFile $f +} -result {file is encrypted or is not a database} +test http-cookiejar-3.10 {cookie storage: class} -setup { + catch {rename ::cookiejar ""} + set dir [makeDirectory cookiejar] +} -constraints cookiejar -body { + http::cookiejar create ::cookiejar $dir +} -returnCodes error -cleanup { + catch {rename ::cookiejar ""} + removeDirectory $dir +} -result {unable to open database file} + +test http-cookiejar-4.1 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + cookiejar +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar method ?arg ...?"} +test http-cookiejar-4.2 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + cookiejar ? +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {unknown method "?": must be destroy, forceLoadDomainData, getCookies, lookup or storeCookie} +test http-cookiejar-4.3 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + lsort [info object methods cookiejar -all] +} -cleanup { + ::cookiejar destroy +} -result {destroy forceLoadDomainData getCookies lookup storeCookie} +test http-cookiejar-4.4 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + cookiejar getCookies +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar getCookies proto host path"} +test http-cookiejar-4.5 {cookie storage} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + cookiejar getCookies http www.example.com / +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-4.6 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + cookiejar storeCookie +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar storeCookie options"} +test http-cookiejar-4.7 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-4.8 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + oo::objdefine ::cookiejar export Database +} -constraints cookiejar -body { + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + # Poke inside implementation! + cookiejar Database eval {SELECT count(*) FROM sessionCookies} +} -cleanup { + ::cookiejar destroy +} -result 1 +test http-cookiejar-4.9 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + oo::objdefine ::cookiejar export Database +} -constraints cookiejar -body { + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + # Poke inside implementation! + cookiejar Database eval {SELECT count(*) FROM persistentCookies} +} -cleanup { + ::cookiejar destroy +} -result 0 +test http-cookiejar-4.10 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + cookiejar storeCookie [dict replace { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-4.11 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + oo::objdefine ::cookiejar export Database +} -constraints cookiejar -body { + cookiejar storeCookie [dict replace { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + # Poke inside implementation! + cookiejar Database eval {SELECT count(*) FROM sessionCookies} +} -cleanup { + ::cookiejar destroy +} -result 0 +test http-cookiejar-4.12 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + oo::objdefine ::cookiejar export Database +} -constraints cookiejar -body { + cookiejar storeCookie [dict replace { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + # Poke inside implementation! + cookiejar Database eval {SELECT count(*) FROM persistentCookies} +} -cleanup { + ::cookiejar destroy +} -result 1 +test http-cookiejar-4.13 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + lappend result [cookiejar getCookies http www.example.com /] + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + lappend result [cookiejar getCookies http www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{} {foo bar}} +test http-cookiejar-4.14 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + lappend result [cookiejar getCookies http www.example.com /] + cookiejar storeCookie [dict replace { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + lappend result [cookiejar getCookies http www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{} {foo bar}} +test http-cookiejar-4.15 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + lappend result [cookiejar getCookies http www.example.com /] + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie [dict replace { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + lappend result [cookiejar getCookies http www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{} {foo bar}} +test http-cookiejar-4.16 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + lappend result [cookiejar getCookies http www.example.com /] + cookiejar storeCookie { + key foo1 + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie [dict replace { + key foo2 + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + lappend result [lsort -stride 2 [cookiejar getCookies http www.example.com /]] +} -cleanup { + ::cookiejar destroy +} -result {{} {foo1 bar foo2 bar}} +test http-cookiejar-4.17 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar +} -constraints cookiejar -body { + cookiejar lookup a b c d +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar lookup ?host? ?key?"} +test http-cookiejar-4.18 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + lappend result [cookiejar lookup] + lappend result [cookiejar lookup www.example.com] + lappend result [catch {cookiejar lookup www.example.com foo} value] $value + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + lappend result [cookiejar lookup] + lappend result [cookiejar lookup www.example.com] + lappend result [cookiejar lookup www.example.com foo] +} -cleanup { + ::cookiejar destroy +} -result {{} {} 1 {no such key for that host} www.example.com foo bar} +test http-cookiejar-4.19 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + cookiejar storeCookie { + key foo + value bar + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key bar + value foo + secure 0 + domain www.example.org + origin www.example.org + path / + hostonly 1 + } + lappend result [lsort [cookiejar lookup]] + lappend result [cookiejar lookup www.example.com] + lappend result [cookiejar lookup www.example.com foo] + lappend result [cookiejar lookup www.example.org] + lappend result [cookiejar lookup www.example.org bar] +} -cleanup { + ::cookiejar destroy +} -result {{www.example.com www.example.org} foo bar bar foo} +test http-cookiejar-4.20 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + cookiejar storeCookie { + key foo1 + value bar1 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie [dict replace { + key foo2 + value bar2 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+5}]] + lappend result [cookiejar lookup] + lappend result [lsort [cookiejar lookup www.example.com]] + lappend result [cookiejar lookup www.example.com foo1] + lappend result [cookiejar lookup www.example.com foo2] +} -cleanup { + ::cookiejar destroy +} -result {www.example.com {foo1 foo2} bar1 bar2} +test http-cookiejar-4.21 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + cookiejar storeCookie { + key foo1 + value bar1 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo2 + value bar2 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + lappend result [cookiejar lookup] + lappend result [lsort [cookiejar lookup www.example.com]] + lappend result [cookiejar lookup www.example.com foo1] + lappend result [cookiejar lookup www.example.com foo2] +} -cleanup { + ::cookiejar destroy +} -result {www.example.com {foo1 foo2} bar1 bar2} +test http-cookiejar-4.22 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + cookiejar forceLoadDomainData x y z +} -returnCodes error -cleanup { + ::cookiejar destroy +} -result {wrong # args: should be "cookiejar forceLoadDomainData"} +test http-cookiejar-4.23 {cookie storage: instance} -setup { + http::cookiejar create ::cookiejar + set result {} +} -constraints cookiejar -body { + cookiejar forceLoadDomainData +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-4.23.a {cookie storage: instance} -setup { + set off [http::cookiejar configure -offline] +} -constraints cookiejar -body { + http::cookiejar configure -offline 1 + [http::cookiejar create ::cookiejar] destroy +} -cleanup { + catch {::cookiejar destroy} + http::cookiejar configure -offline $off +} -result {} +test http-cookiejar-4.23.b {cookie storage: instance} -setup { + set off [http::cookiejar configure -offline] +} -constraints cookiejar -body { + http::cookiejar configure -offline 0 + [http::cookiejar create ::cookiejar] destroy +} -cleanup { + catch {::cookiejar destroy} + http::cookiejar configure -offline $off +} -result {} + +test http-cookiejar-5.1 {cookie storage: constraints} -setup { + http::cookiejar create ::cookiejar + cookiejar forceLoadDomainData +} -constraints cookiejar -body { + cookiejar storeCookie { + key foo + value bar + secure 0 + domain com + origin com + path / + hostonly 1 + } + cookiejar lookup +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-5.2 {cookie storage: constraints} -setup { + http::cookiejar create ::cookiejar + cookiejar forceLoadDomainData +} -constraints cookiejar -body { + cookiejar storeCookie { + key foo + value bar + secure 0 + domain foo.example.com + origin bar.example.org + path / + hostonly 1 + } + cookiejar lookup +} -cleanup { + ::cookiejar destroy +} -result {} +test http-cookiejar-5.3 {cookie storage: constraints} -setup { + http::cookiejar create ::cookiejar + cookiejar forceLoadDomainData +} -constraints cookiejar -body { + cookiejar storeCookie { + key foo1 + value bar + secure 0 + domain com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo2 + value bar + secure 0 + domain example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar lookup +} -cleanup { + ::cookiejar destroy +} -result {example.com} +test http-cookiejar-5.4 {cookie storage: constraints} -setup { + http::cookiejar create ::cookiejar + cookiejar forceLoadDomainData +} -constraints cookiejar -body { + cookiejar storeCookie { + key foo + value bar1 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo + value bar2 + secure 0 + domain example.com + origin www.example.com + path / + hostonly 1 + } + lsort [cookiejar lookup] +} -cleanup { + ::cookiejar destroy +} -result {example.com www.example.com} +test http-cookiejar-5.5 {cookie storage: constraints} -setup { + http::cookiejar create ::cookiejar + cookiejar forceLoadDomainData +} -constraints cookiejar -body { + cookiejar storeCookie { + key foo1 + value 1 + secure 0 + domain com + origin www.example.com + path / + hostonly 0 + } + cookiejar storeCookie { + key foo2 + value 2 + secure 0 + domain com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo3 + value 3 + secure 0 + domain example.com + origin www.example.com + path / + hostonly 0 + } + cookiejar storeCookie { + key foo4 + value 4 + secure 0 + domain example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo5 + value 5 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 0 + } + cookiejar storeCookie { + key foo6 + value 6 + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo7 + value 7 + secure 1 + domain www.example.com + origin www.example.com + path / + hostonly 0 + } + cookiejar storeCookie { + key foo8 + value 8 + secure 1 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + cookiejar storeCookie { + key foo9 + value 9 + secure 0 + domain sub.www.example.com + origin www.example.com + path / + hostonly 1 + } + list [cookiejar getCookies http www.example.com /] \ + [cookiejar getCookies http www2.example.com /] \ + [cookiejar getCookies https www.example.com /] \ + [cookiejar getCookies http sub.www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{foo3 3 foo6 6} {foo3 3} {foo3 3 foo6 6 foo8 8} {foo3 3 foo5 5}} + +test http-cookiejar-6.1 {cookie storage: expiry and lookup} -setup { + http::cookiejar create ::cookiejar + oo::objdefine cookiejar export PurgeCookies + set result {} + proc values cookies { + global result + lappend result [lsort [lmap {k v} $cookies {set v}]] + } +} -constraints cookiejar -body { + values [cookiejar getCookies http www.example.com /] + cookiejar storeCookie { + key foo + value session + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } + values [cookiejar getCookies http www.example.com /] + cookiejar storeCookie [dict replace { + key foo + value cookie + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+1}]] + values [cookiejar getCookies http www.example.com /] + cookiejar storeCookie { + key foo + value session-global + secure 0 + domain example.com + origin www.example.com + path / + hostonly 0 + } + values [cookiejar getCookies http www.example.com /] + after 2500 + update + values [cookiejar getCookies http www.example.com /] + cookiejar PurgeCookies + values [cookiejar getCookies http www.example.com /] + cookiejar storeCookie { + key foo + value go-away + secure 0 + domain example.com + origin www.example.com + path / + hostonly 0 + expires 0 + } + values [cookiejar getCookies http www.example.com /] +} -cleanup { + ::cookiejar destroy +} -result {{} session cookie {cookie session-global} {cookie session-global} session-global {}} + +test http-cookiejar-7.1 {cookie storage: persistence of persistent cookies} -setup { + catch {rename ::cookiejar ""} + set f [makeFile "" cookiejar] + file delete $f +} -constraints cookiejar -body { + http::cookiejar create ::cookiejar $f + ::cookiejar destroy + http::cookiejar create ::cookiejar $f +} -cleanup { + catch {rename ::cookiejar ""} + removeFile $f +} -result ::cookiejar +test http-cookiejar-7.2 {cookie storage: persistence of persistent cookies} -setup { + catch {rename ::cookiejar ""} + set f [makeFile "" cookiejar] + file delete $f + set result {} +} -constraints cookiejar -body { + http::cookiejar create ::cookiejar $f + cookiejar storeCookie [dict replace { + key foo + value cookie + secure 0 + domain www.example.com + origin www.example.com + path / + hostonly 1 + } expires [expr {[clock seconds]+1}]] + lappend result [::cookiejar getCookies http www.example.com /] + ::cookiejar destroy + http::cookiejar create ::cookiejar + lappend result [::cookiejar getCookies http www.example.com /] + ::cookiejar destroy + http::cookiejar create ::cookiejar $f + lappend result [::cookiejar getCookies http www.example.com /] +} -cleanup { + catch {rename ::cookiejar ""} + removeFile $f +} -result {{foo cookie} {} {foo cookie}} + +::tcltest::cleanupTests + +# Local variables: +# mode: tcl +# End: diff --git a/tests/httpd b/tests/httpd index 16e0382..982f3b8 100644 --- a/tests/httpd +++ b/tests/httpd @@ -18,7 +18,12 @@ if {$::tcl_platform(os) eq "Darwin"} { } proc httpd_init {{port 8015}} { - socket -server httpdAccept $port + set s [socket -server httpdAccept $port] + # Save the actual port number in a global variable. + # This is important when we're called with port 0 + # for picking an unused port at random. + set ::port [lindex [chan configure $s -sockname] 2] + return $s } proc httpd_log {args} { global httpLog @@ -216,7 +221,7 @@ proc httpdRespond { sock } { } # Catch errors from premature client closes - + catch { if {$data(proto) == "HEAD"} { puts $sock "HTTP/1.0 200 OK" diff --git a/tests/httpold.test b/tests/httpold.test deleted file mode 100644 index e63bcda..0000000 --- a/tests/httpold.test +++ /dev/null @@ -1,300 +0,0 @@ -# Commands covered: http_config, http_get, http_wait, http_reset -# -# This file contains a collection of tests for the http script library. -# Sourcing this file into Tcl runs the tests and -# generates output for errors. No output means no errors were found. -# -# Copyright (c) 1991-1993 The Regents of the University of California. -# Copyright (c) 1994-1996 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 {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} - -if {[catch {package require http 1.0}]} { - if {[info exists httpold]} { - catch {puts "Cannot load http 1.0 package"} - ::tcltest::cleanupTests - return - } else { - catch {puts "Running http 1.0 tests in slave interp"} - set interp [interp create httpold] - $interp eval [list set httpold "running"] - $interp eval [list set argv $argv] - $interp eval [list source [info script]] - interp delete $interp - ::tcltest::cleanupTests - return - } -} - -if {$::tcl_platform(os) eq "Darwin"} { - # Name resolution often a problem on OSX; not focus of HTTP package anyway - set HOST localhost -} else { - set HOST [info hostname] -} - -set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" -catch {unset data} - -## -## The httpd script implement a stub http server -## -source [file join [file dirname [info script]] httpd] - -set port 8010 -if [catch {httpd_init $port} listen] { - puts "Cannot start http server, http test skipped" - unset port - ::tcltest::cleanupTests - return -} - -test httpold-1.1 {http_config} { - http_config -} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}} - -test httpold-1.2 {http_config} { - http_config -proxyfilter -} httpProxyRequired - -test httpold-1.3 {http_config} { - catch {http_config -junk} -} 1 - -test httpold-1.4 {http_config} { - http_config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite" - set x [http_config] - http_config -proxyhost {} -proxyport {} -proxyfilter httpProxyRequired \ - -useragent "Tcl http client package 1.0" - set x -} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}} - -test httpold-1.5 {http_config} { - catch {http_config -proxyhost {} -junk 8080} -} 1 - -test httpold-2.1 {http_reset} { - catch {http_reset http#1} -} 0 - -test httpold-3.1 {http_get} { - catch {http_get -bogus flag} -} 1 -test httpold-3.2 {http_get} { - catch {http_get http:junk} err - set err -} {Unsupported URL: http:junk} - -set url ${::HOST}:$port -test httpold-3.3 {http_get} { - set token [http_get $url] - http_data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET /</h2> -</body></html>" - -set tail /a/b/c -set url ${::HOST}:$port/a/b/c -set binurl ${::HOST}:$port/binary - -test httpold-3.4 {http_get} { - set token [http_get $url] - http_data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET $tail</h2> -</body></html>" - -proc selfproxy {host} { - global port - return [list ${::HOST} $port] -} -test httpold-3.5 {http_get} { - http_config -proxyfilter selfproxy - set token [http_get $url] - http_config -proxyfilter httpProxyRequired - http_data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET http://$url</h2> -</body></html>" - -test httpold-3.6 {http_get} { - http_config -proxyfilter bogus - set token [http_get $url] - http_config -proxyfilter httpProxyRequired - http_data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET $tail</h2> -</body></html>" - -test httpold-3.7 {http_get} { - set token [http_get $url -headers {Pragma no-cache}] - http_data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET $tail</h2> -</body></html>" - -test httpold-3.8 {http_get} { - set token [http_get $url -query Name=Value&Foo=Bar] - http_data $token -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>POST $tail</h2> -<h2>Query</h2> -<dl> -<dt>Name<dd>Value -<dt>Foo<dd>Bar -</dl> -</body></html>" - -test httpold-3.9 {http_get} { - set token [http_get $url -validate 1] - http_code $token -} "HTTP/1.0 200 OK" - - -test httpold-4.1 {httpEvent} { - set token [http_get $url] - upvar #0 $token data - array set meta $data(meta) - expr ($data(totalsize) == $meta(Content-Length)) -} 1 - -test httpold-4.2 {httpEvent} { - set token [http_get $url] - upvar #0 $token data - array set meta $data(meta) - string compare $data(type) [string trim $meta(Content-Type)] -} 0 - -test httpold-4.3 {httpEvent} { - set token [http_get $url] - http_code $token -} {HTTP/1.0 200 Data follows} - -test httpold-4.4 {httpEvent} { - set testfile [makeFile "" testfile] - set out [open $testfile w] - set token [http_get $url -channel $out] - close $out - set in [open $testfile] - set x [read $in] - close $in - removeFile $testfile - set x -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET $tail</h2> -</body></html>" - -test httpold-4.5 {httpEvent} { - set testfile [makeFile "" testfile] - set out [open $testfile w] - set token [http_get $url -channel $out] - close $out - upvar #0 $token data - removeFile $testfile - expr $data(currentsize) == $data(totalsize) -} 1 - -test httpold-4.6 {httpEvent} { - set testfile [makeFile "" testfile] - set out [open $testfile w] - set token [http_get $binurl -channel $out] - close $out - set in [open $testfile] - fconfigure $in -translation binary - set x [read $in] - close $in - removeFile $testfile - set x -} "$bindata$binurl" - -proc myProgress {token total current} { - global progress httpLog - if {[info exists httpLog] && $httpLog} { - puts "progress $total $current" - } - set progress [list $total $current] -} -if 0 { - # This test hangs on Windows95 because the client never gets EOF - set httpLog 1 - test httpold-4.6 {httpEvent} { - set token [http_get $url -blocksize 50 -progress myProgress] - set progress - } {111 111} -} -test httpold-4.7 {httpEvent} { - set token [http_get $url -progress myProgress] - set progress -} {111 111} -test httpold-4.8 {httpEvent} { - set token [http_get $url] - http_status $token -} {ok} -test httpold-4.9 {httpEvent} { - set token [http_get $url -progress myProgress] - http_code $token -} {HTTP/1.0 200 Data follows} -test httpold-4.10 {httpEvent} { - set token [http_get $url -progress myProgress] - http_size $token -} {111} -test httpold-4.11 {httpEvent} { - set token [http_get $url -timeout 1 -command {#}] - http_reset $token - http_status $token -} {reset} -test httpold-4.12 {httpEvent} { - update - set x {} - after 500 {lappend x ok} - set token [http_get $url -timeout 1 -command {lappend x fail}] - vwait x - list [http_status $token] $x -} {timeout ok} - -test httpold-5.1 {http_formatQuery} { - http_formatQuery name1 value1 name2 "value two" -} {name1=value1&name2=value+two} - -test httpold-5.2 {http_formatQuery} { - http_formatQuery name1 ~bwelch name2 \xa1\xa2\xa2 -} {name1=%7ebwelch&name2=%a1%a2%a2} - -test httpold-5.3 {http_formatQuery} { - http_formatQuery lines "line1\nline2\nline3" -} {lines=line1%0d%0aline2%0d%0aline3} - -test httpold-6.1 {httpProxyRequired} { - update - http_config -proxyhost ${::HOST} -proxyport $port - set token [http_get $url] - http_wait $token - http_config -proxyhost {} -proxyport {} - upvar #0 $token data - set data(body) -} "<html><head><title>HTTP/1.0 TEST</title></head><body> -<h1>Hello, World!</h1> -<h2>GET http://$url</h2> -</body></html>" - -# cleanup -catch {unset url} -catch {unset port} -catch {unset data} -close $listen -::tcltest::cleanupTests -return diff --git a/tests/incr.test b/tests/incr.test index 9243be0..aa2872a 100644 --- a/tests/incr.test +++ b/tests/incr.test @@ -494,6 +494,18 @@ test incr-2.31 {incr command (compiled): bad increment} { (reading increment) invoked from within "incr x 1a"}} +test incr-2.32 {incr command (compiled): bad pure list increment} { + list [catch {incr x [list 1 2]} msg] $msg $::errorInfo +} {1 {expected integer but got "1 2"} {expected integer but got "1 2" + (reading increment) + invoked from within +"incr x [list 1 2]"}} +test incr-2.33 {incr command (compiled): bad pure dict increment} { + list [catch {incr x [dict create 1 2]} msg] $msg $::errorInfo +} {1 {expected integer but got "1 2"} {expected integer but got "1 2" + (reading increment) + invoked from within +"incr x [dict create 1 2]"}} test incr-3.1 {increment by wide amount: bytecode route} { set x 0 diff --git a/tests/indexObj.test b/tests/indexObj.test index 646cb02..126d062 100644 --- a/tests/indexObj.test +++ b/tests/indexObj.test @@ -109,7 +109,7 @@ test indexObj-5.6 {Tcl_WrongNumArgs} testindexobj { } "wrong # args: should be \"mycmd foo\"" # Contrast this with test proc-3.6; they have to be like this because # of [Bug 1066837] so Itcl won't break. -test indexObj-5.7 {Tcl_WrongNumArgs} testindexobj { +test indexObj-5.7 {Tcl_WrongNumArgs} {testindexobj obsolete} { testwrongnumargs 2 "fee fi" "fo fum" foo bar } "wrong # args: should be \"fo fum foo fee fi\"" diff --git a/tests/info.test b/tests/info.test index 1b52cf5..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 @@ -397,8 +397,8 @@ test info-10.3 {info library option} -body { set tcl_library $savedLibrary; unset savedLibrary test info-11.1 {info loaded option} -body { - info loaded a b -} -returnCodes error -result {wrong # args: should be "info loaded ?interp?"} + info loaded a b c +} -returnCodes error -result {wrong # args: should be "info loaded ?interp? ?packageName?"} test info-11.2 {info loaded option} -body { info loaded {}; info loaded gorp } -returnCodes error -result {could not find interpreter "gorp"} @@ -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} ## # ### ### ### ######### ######### ######### @@ -1841,7 +1841,7 @@ test info-30.48 {Bug 2850901} testevalex { # ------------------------------------------------------------------------- # literal sharing 2, bug 2933089 -test info-40.1 {location information not confused by literal sharing, bug 2933089} -setup { +test info-39.1 {location information not confused by literal sharing, bug 2933089} -setup { set result {} proc print_one {} {} @@ -2099,7 +2099,7 @@ proc foo::bar {} { foreach {*}{ x y {set res [info frame 0]} - } + } return $res } test info-33.13 {{*}, literal, simple, bytecompiled} -body { @@ -2114,7 +2114,7 @@ proc foo::bar {} { if {*}{ {[return [info frame 0]]} {} - } + } } test info-33.14 {{*}, literal, simple, bytecompiled} -body { reduce [foo::bar] @@ -2128,7 +2128,7 @@ proc foo::bar {} { if 0 {*}{ {} else {return [info frame 0]} - } + } } test info-33.15 {{*}, literal, simple, bytecompiled} -body { reduce [foo::bar] @@ -2229,7 +2229,7 @@ namespace eval foo {} proc foo::bar {} { try {*}{ {set res [info frame 0]} - } + } return $res } test info-33.23 {{*}, literal, simple, bytecompiled} -body { @@ -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/init.test b/tests/init.test index 639389f..2a81b52 100644 --- a/tests/init.test +++ b/tests/init.test @@ -28,7 +28,7 @@ test init-1.2 {auto_qualify - absolute cmd - global} { } global test init-1.3 {auto_qualify - no colons cmd - global} { auto_qualify nocolons :: -} nocolons +} nocolons test init-1.4 {auto_qualify - no colons cmd - namespace} { auto_qualify nocolons ::sub } {::sub::nocolons nocolons} @@ -93,11 +93,11 @@ test init-2.5 {load safe:::setLogCmd - stage 2} { auto_reset catch {rename ::safe::setLogCmd {}} test init-2.6 {load setLogCmd from safe:: - stage 1} { - namespace eval safe setLogCmd + namespace eval safe setLogCmd rename ::safe::setLogCmd {} ;# should not fail } {} test init-2.7 {oad setLogCmd from safe:: - stage 2} { - namespace eval safe setLogCmd + namespace eval safe setLogCmd rename ::safe::setLogCmd {} ;# should not fail } {} test init-2.8 {load tcl::HistAdd} -setup { @@ -132,12 +132,12 @@ foreach arg [subst -nocommands -novariables { and is long enough to be truncated and " <- includes a false lead in the prune point search and must be longer still to force truncation} - {contrived example: rare circumstance + {contrived example: rare circumstance where the point at which to prune the error stack cannot be uniquely determined. foo bar foo "} - {contrived example: rare circumstance + {contrived example: rare circumstance where the point at which to prune the error stack cannot be uniquely determined. foo bar diff --git a/tests/interp.test b/tests/interp.test index 5299d82..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 @@ -56,7 +56,7 @@ test interp-1.8 {options for interp command} -returnCodes error -body { } -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} test interp-1.9 {options for interp command} -returnCodes error -body { interp -froboz -safe -} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} +} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, slaves, share, target, or transfer} test interp-1.10 {options for interp command} -returnCodes error -body { interp target } -result {wrong # args: should be "interp target path alias"} @@ -70,7 +70,7 @@ test interp-2.2 {basic interpreter creation} { } 0 test interp-2.3 {basic interpreter creation} { catch {interp create -safe} -} 0 +} 0 test interp-2.4 {basic interpreter creation} -setup { catch {interp create a} } -returnCodes error -body { @@ -106,7 +106,7 @@ test interp-2.11 {anonymous interps vs existing procs} { set x [interp create] regexp "interp(\[0-9]+)" $x dummy anothernum expr $anothernum > $thenum -} 1 +} 1 test interp-2.12 {anonymous interps vs existing procs} { set x [interp create -safe] regexp "interp(\[0-9]+)" $x dummy thenum @@ -876,12 +876,12 @@ test interp-18.9 {eval in deleted interp, bug 495830} { interp create tst interp alias tst suicide {} interp delete tst list [catch {tst eval {suicide; set a 5}} msg] $msg -} {1 {attempt to call eval in deleted interpreter}} +} {1 {attempt to call eval in deleted interpreter}} test interp-18.10 {eval in deleted interp, bug 495830} { interp create tst interp alias tst suicide {} interp delete tst list [catch {tst eval {set set set; suicide; $set a 5}} msg] $msg -} {1 {attempt to call eval in deleted interpreter}} +} {1 {attempt to call eval in deleted interpreter}} # Test alias deletion @@ -971,7 +971,7 @@ test interp-19.9 {alias deletion, renaming} { set l [interp eval a foo] interp delete a set l -} 1156 +} 1156 test interp-20.1 {interp hide, interp expose and interp invokehidden} { set a [interp create] @@ -1192,7 +1192,7 @@ test interp-20.21 {interp hide vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a hide list} msg] + lappend l [catch {a hide list} msg] lappend l $msg interp delete a set l @@ -1201,7 +1201,7 @@ test interp-20.22 {interp hide vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {interp hide a list} msg] + lappend l [catch {interp hide a list} msg] lappend l $msg interp delete a set l @@ -1210,7 +1210,7 @@ test interp-20.23 {interp hide vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a eval {interp hide {} list}} msg] + lappend l [catch {a eval {interp hide {} list}} msg] lappend l $msg interp delete a set l @@ -1220,7 +1220,7 @@ test interp-20.24 {interp hide vs safety} { interp create a -safe interp create {a b} set l "" - lappend l [catch {a eval {interp hide b list}} msg] + lappend l [catch {a eval {interp hide b list}} msg] lappend l $msg interp delete a set l @@ -1239,7 +1239,7 @@ test interp-20.26 {interp expoose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a hide list} msg] + lappend l [catch {a hide list} msg] lappend l $msg lappend l [catch {a expose list} msg] lappend l $msg @@ -1250,9 +1250,9 @@ test interp-20.27 {interp expose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {interp hide a list} msg] + lappend l [catch {interp hide a list} msg] lappend l $msg - lappend l [catch {interp expose a list} msg] + lappend l [catch {interp expose a list} msg] lappend l $msg interp delete a set l @@ -1261,7 +1261,7 @@ test interp-20.28 {interp expose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {a hide list} msg] + lappend l [catch {a hide list} msg] lappend l $msg lappend l [catch {a eval {interp expose {} list}} msg] lappend l $msg @@ -1272,9 +1272,9 @@ test interp-20.29 {interp expose vs safety} { catch {interp delete a} interp create a -safe set l "" - lappend l [catch {interp hide a list} msg] + lappend l [catch {interp hide a list} msg] lappend l $msg - lappend l [catch {a eval {interp expose {} list}} msg] + lappend l [catch {a eval {interp expose {} list}} msg] lappend l $msg interp delete a set l @@ -1284,9 +1284,9 @@ test interp-20.30 {interp expose vs safety} { interp create a -safe interp create {a b} set l "" - lappend l [catch {interp hide {a b} list} msg] + lappend l [catch {interp hide {a b} list} msg] lappend l $msg - lappend l [catch {a eval {interp expose b list}} msg] + lappend l [catch {a eval {interp expose b list}} msg] lappend l $msg interp delete a set l @@ -1296,7 +1296,7 @@ test interp-20.31 {interp expose vs safety} { interp create a -safe interp create {a b} set l "" - lappend l [catch {interp hide {a b} list} msg] + lappend l [catch {interp hide {a b} list} msg] lappend l $msg lappend l [catch {interp expose {a b} list} msg] lappend l $msg @@ -1676,7 +1676,7 @@ test interp-21.5 {interp hidden} -setup { lsort [interp hidden a] } -cleanup { interp delete a -} -result $hidden_cmds +} -result $hidden_cmds test interp-21.6 {interp hidden vs interp hide, interp expose} -setup { catch {interp delete a} set l "" @@ -1847,7 +1847,7 @@ test interp-23.2 {testing hiding vs aliases: safe interp} -setup { lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] } -cleanup { interp delete a -} -result [list $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} [lsort [concat $hidden_cmds bar]] {::tcl::mathfunc::max ::tcl::mathfunc::min clock} $hidden_cmds] +} -result [list $hidden_cmds {bar clock} $hidden_cmds {bar clock} [lsort [concat $hidden_cmds bar]] {clock} $hidden_cmds] test interp-24.1 {result resetting on error} -setup { catch {interp delete a} @@ -2200,7 +2200,7 @@ test interp-27.1 {interp aliases & namespaces} -setup { set i [interp create] } -body { set aliasTrace {} - proc tstAlias {args} { + proc tstAlias {args} { global aliasTrace lappend aliasTrace [list [namespace current] $args] } @@ -2214,7 +2214,7 @@ test interp-27.2 {interp aliases & namespaces} -setup { set i [interp create] } -body { set aliasTrace {} - proc tstAlias {args} { + proc tstAlias {args} { global aliasTrace lappend aliasTrace [list [namespace current] $args] } @@ -2228,7 +2228,7 @@ test interp-27.3 {interp aliases & namespaces} -setup { set i [interp create] } -body { set aliasTrace {} - proc tstAlias {args} { + proc tstAlias {args} { global aliasTrace lappend aliasTrace [list [namespace current] $args] } @@ -2244,7 +2244,7 @@ test interp-27.4 {interp aliases & namespaces} -setup { } -body { namespace eval foo2 { variable aliasTrace {} - proc bar {args} { + proc bar {args} { variable aliasTrace lappend aliasTrace [list [namespace current] $args] } @@ -3321,7 +3321,7 @@ test interp-34.9 {time limits trigger in blocking after} { } msg] set t1 [clock seconds] interp delete $i - list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}] + list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}] } {1 {time limit exceeded} OK} test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body { set i [interp create] @@ -3555,7 +3555,7 @@ test interp-35.24 {interp time limits can't touch current interp} -body { test interp-36.1 {interp bgerror syntax} -body { interp bgerror } -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"} -test interp-36.2 {interp bgerror syntax} -body { +test interp-36.2 {interp bgerror syntax} -body { interp bgerror x y z } -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"} test interp-36.3 {interp bgerror syntax} -setup { diff --git a/tests/io.test b/tests/io.test index cdecb7b..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 @@ -124,10 +119,10 @@ test io-1.8 {Tcl_WriteChars: WriteChars} { # applied to tcl will cause tcl, more specifically WriteChars, to # go into an infinite loop. - set f [open $path(test2) w] - fconfigure $f -encoding iso2022-jp - puts -nonewline $f [format %s%c [string repeat " " 4] 12399] - close $f + set f [open $path(test2) w] + fconfigure $f -encoding iso2022-jp + puts -nonewline $f [format %s%c [string repeat " " 4] 12399] + close $f contents $path(test2) } " \x1b\$B\$O\x1b(B" @@ -193,7 +188,7 @@ test io-1.9 {Tcl_WriteChars: WriteChars} { test io-2.1 {WriteBytes} { # loop until all bytes are written - + set f [open $path(test1) w] fconfigure $f -encoding binary -buffersize 16 -translation crlf puts $f "abcdefghijklmnopqrstuvwxyz" @@ -215,7 +210,7 @@ test io-2.3 {WriteBytes: flush on line} { # Tcl "line" buffering has weird behavior: if current buffer contains # a \n, entire buffer gets flushed. Logical behavior would be to flush # only up to the \n. - + set f [open $path(test1) w] fconfigure $f -encoding binary -buffering line -translation crlf puts -nonewline $f "\n12" @@ -235,7 +230,7 @@ test io-2.4 {WriteBytes: reset sawLF after each buffer} { test io-3.1 {WriteChars: compatibility with WriteBytes} { # loop until all bytes are written - + set f [open $path(test1) w] fconfigure $f -encoding ascii -buffersize 16 -translation crlf puts $f "abcdefghijklmnopqrstuvwxyz" @@ -257,7 +252,7 @@ test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} { # Tcl "line" buffering has weird behavior: if current buffer contains # a \n, entire buffer gets flushed. Logical behavior would be to flush # only up to the \n. - + set f [open $path(test1) w] fconfigure $f -encoding ascii -buffering line -translation crlf puts -nonewline $f "\n12" @@ -269,7 +264,7 @@ test io-3.4 {WriteChars: loop over stage buffer} { # stage buffer maps to more than can be queued at once. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 16 + fconfigure $f -encoding jis0208 -buffersize 16 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -281,7 +276,7 @@ test io-3.5 {WriteChars: saved != 0} { # requested buffersize. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 17 + fconfigure $f -encoding jis0208 -buffersize 17 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -312,7 +307,7 @@ test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} { # of the next channel buffer. set f [open $path(test1) w] - fconfigure $f -encoding jis0208 -buffersize 17 + fconfigure $f -encoding jis0208 -buffersize 17 puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\" set x [list [contents $path(test1)]] close $f @@ -382,7 +377,7 @@ test io-4.5 {TranslateOutputEOL: crlf} { test io-5.1 {CheckFlush: not full} { set f [open $path(test1) w] - fconfigure $f + fconfigure $f puts -nonewline $f "12345678901234567890" set x [list [contents $path(test1)]] close $f @@ -471,7 +466,7 @@ set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" append a $a append a $a test io-6.6 {Tcl_GetsObj: loop test} { - # if (dst >= dstEnd) + # if (dst >= dstEnd) set f [open $path(test1) w] puts $f $a @@ -770,7 +765,7 @@ test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel} } [list 15 "123456789012345" 17 3] test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} { # eol still equals dstEnd - + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456789012345\r" @@ -782,8 +777,8 @@ test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} { set x } [list 16 "123456789012345\r" 1] test io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} { - # not (*eol == '\n') - + # not (*eol == '\n') + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456789012345\rabcd\r\nefg" @@ -890,7 +885,7 @@ test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} fconfigure $f -buffersize 16 set x [list [gets $f]] fconfigure $f -blocking 0 - lappend x [gets $f line] $line [testchannel queuedcr $f] + lappend x [gets $f line] $line [testchannel queuedcr $f] fconfigure $f -blocking 1 puts -nonewline $f "\nabcd\refg\x1a" lappend x [gets $f line] $line [testchannel queuedcr $f] @@ -899,7 +894,7 @@ test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} set x } [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"] test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe fileevent} { - # not (*eol == '\n') + # not (*eol == '\n') set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto lf} -buffering none @@ -907,7 +902,7 @@ test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel fconfigure $f -buffersize 16 set x [list [gets $f]] fconfigure $f -blocking 0 - lappend x [gets $f line] $line [testchannel queuedcr $f] + lappend x [gets $f line] $line [testchannel queuedcr $f] fconfigure $f -blocking 1 puts -nonewline $f "abcd\refg\x1a" lappend x [gets $f line] $line [testchannel queuedcr $f] @@ -960,10 +955,10 @@ test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {testcha set x [list [gets $f] [testchannel inputbuffered $f]] close $f set x -} [list "123456789012345" 15] +} [list "123456789012345" 15] test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testchannel} { # PeekAhead() did not get any, so (eol >= dstEnd) - + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456789012345\r" @@ -976,7 +971,7 @@ test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testc } [list "123456789012345" 1] test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} { # if (*eol == '\n') {skip++} - + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456\r\n78901" @@ -987,8 +982,8 @@ test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} { set x } [list "123456" 0 8 "78901"] test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} { - # not (*eol == '\n') - + # not (*eol == '\n') + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456\r78901" @@ -1000,7 +995,7 @@ test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} { } [list "123456" 0 7 "78901"] test io-6.51 {Tcl_GetsObj: auto mode: \n} { # else if (*eol == '\n') {goto gotoeol;} - + set f [open $path(test1) w] fconfigure $f -translation lf puts -nonewline $f "123456\n78901" @@ -1093,7 +1088,7 @@ test io-7.1 {FilterInputBytes: split up character at end of buffer} { } "1234567890123\uff10\uff11\uff12\uff13\uff14" test io-7.2 {FilterInputBytes: split up character in middle of buffer} { # (bufPtr->nextAdded < bufPtr->bufLength) - + set f [open $path(test1) w] fconfigure $f -encoding binary puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82" @@ -1202,7 +1197,7 @@ test io-8.4 {PeekAhead: cached data available in this buffer} { set x [gets $f] close $f - set x + set x } $a unset a test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe fileevent} { @@ -1218,7 +1213,7 @@ test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel op set x } {15 abcdefghijklmno 1} test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe fileevent} { - # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) + # ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0) set f [open "|[list [interpreter] $path(cat)]" w+] fconfigure $f -translation {auto binary} -buffersize 16 @@ -1575,7 +1570,7 @@ test io-13.2 {TranslateInputEOL: crlf mode} { set x } "abcd\ndef\n" test io-13.3 {TranslateInputEOL: crlf mode: naked cr} { - # (src >= srcMax) + # (src >= srcMax) set f [open $path(test1) w] fconfigure $f -translation lf @@ -1588,7 +1583,7 @@ test io-13.3 {TranslateInputEOL: crlf mode: naked cr} { set x } "abcd\ndef\r" test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} { - # (src >= srcMax) + # (src >= srcMax) set f [open $path(test1) w] fconfigure $f -translation lf @@ -1601,7 +1596,7 @@ test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} { set x } "abcd\ndef\rfgh" test io-13.5 {TranslateInputEOL: crlf mode: naked lf} { - # (src >= srcMax) + # (src >= srcMax) set f [open $path(test1) w] fconfigure $f -translation lf @@ -1716,7 +1711,7 @@ test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} { set x } "abcd\ndef" test io-13.10 {TranslateInputEOL: auto mode: \n} { - # not (*src == '\r') + # not (*src == '\r') set f [open $path(test1) w] fconfigure $f -translation lf @@ -2065,7 +2060,7 @@ test io-20.1 {Tcl_CreateChannel: initial settings} { encoding system $old close $a set x -} {ascii} +} {ascii} test io-20.2 {Tcl_CreateChannel: initial settings} {win} { set f [open $path(test1) w+] set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]] @@ -2160,7 +2155,7 @@ test io-26.1 {Tcl_GetChannelInstanceData} {stdio openpipe} { set f [open "|[list [interpreter] << exit]"] expr [pid $f] close $f -} {} +} {} # Test flushing. The functions tested here are FlushChannel. @@ -3058,7 +3053,7 @@ test io-30.6 {Tcl_Write cr, Tcl_Read crlf} { fconfigure $f -translation crlf set x [read $f] close $f - set x + set x } "hello\rthere\rand\rhere\r" test io-30.7 {Tcl_Write crlf, Tcl_Read crlf} { file delete $path(test1) @@ -3986,7 +3981,7 @@ test io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} { } close $f set f [open $path(test1) r] - fconfigure $f -translation crlf + fconfigure $f -translation crlf set c "" while {[gets $f line] >= 0} { append c $line\n @@ -5475,7 +5470,7 @@ test io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} { test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} { file delete $path(test1) set f [open $path(test1) w] - fconfigure $f -encoding {} + fconfigure $f -encoding {} puts -nonewline $f \xe7\x89\xa6 close $f set f [open $path(test1) r] @@ -5638,7 +5633,7 @@ test io-40.2 {POSIX open access modes: CREAT} {unix} { file delete $path(test3) set f [open $path(test3) {WRONLY CREAT} 0o600] file stat $path(test3) stats - set x [format "0o%o" [expr $stats(mode)&0o777]] + set x [format "%#o" [expr $stats(mode)&0o777]] puts $f "line 1" close $f set f [open $path(test3) r] @@ -5653,7 +5648,7 @@ test io-40.3 {POSIX open access modes: CREAT} {unix umask} { close $f file stat $path(test3) stats format "%#o" [expr $stats(mode)&0o777] -} [format %#4o [expr {0o666 & ~ $umaskValue}]] +} [format %#5o [expr {0o666 & ~ $umaskValue}]] test io-40.4 {POSIX open access modes: CREAT} { file delete $path(test3) set f [open $path(test3) w] @@ -8651,11 +8646,11 @@ test io-74.1 {[104f2885bb] improper cache validity check} -setup { interp create slave } -constraints testobj -body { teststringobj set 1 [string range $rfd 0 end] - read [teststringobj get 1] + read [teststringobj get 1] testobj duplicate 1 2 interp transfer {} $rfd slave catch {read [teststringobj get 1]} - read [teststringobj get 2] + read [teststringobj get 2] } -cleanup { interp delete slave testobj freeallvars diff --git a/tests/ioCmd.test b/tests/ioCmd.test index b4ba04a..68bc542 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -14,17 +14,17 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 + package require tcltest 2.5 namespace import -force ::tcltest::* } ::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-}]}] #---------------------------------------------------------------------- @@ -154,10 +154,10 @@ test iocmd-4.11 {read command} { test iocmd-4.12 {read command} -setup { set f [open $path(test1)] } -body { - list [catch {read $f 12z} msg] $msg $::errorCode + read $f 12z } -cleanup { close $f -} -result {1 {expected non-negative integer but got "12z"} {TCL VALUE NUMBER}} +} -result {expected non-negative integer but got "12z"} -errorCode {TCL VALUE NUMBER} test iocmd-5.1 {seek command} -returnCodes error -body { seek @@ -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}}} @@ -2057,6 +2057,8 @@ test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body { lappend res [catch {interp eval $idb [list close $chan]} msg] $msg set res +} -cleanup { + interp delete $idb } -constraints {testchannel} \ -result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} @@ -2099,6 +2101,8 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m set res }] set res +} -cleanup { + interp delete $idb } -constraints {testchannel} -result {Owner lost} test iocmd-32.2 {delete interp of reflected chan} { @@ -3777,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 @@ -3830,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 e179eab..0a335ff 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -1200,6 +1200,7 @@ test iortrans-11.0 {origin interpreter of moved transform gone} -setup { # without invoking the transform handler. } -cleanup { tempdone + interp delete $idb } -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup { set ida [interp create]; #puts <<$ida>> @@ -1239,6 +1240,7 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces set res }] } -cleanup { + interp delete $idb tempdone } -result {Owner lost} test iortrans-11.2 {delete interp of reflected transform} -setup { @@ -1318,7 +1320,7 @@ proc inthread {chan script args} { # forwarded channel operations. set ::tres "" - thread::send -async $tid { + thread::send -async $tid { after 50 catch {s} res; # This runs the script, 's' was defined at (*) thread::send -async $mid [list set ::tres $res] diff --git a/tests/iogt.test b/tests/iogt.test index 1ed89f7..3cac2cf 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -5,7 +5,7 @@ # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -# +# # Copyright (c) 2000 Ajuba Solutions. # Copyright (c) 2000 Andreas Kupries. # All rights reserved. @@ -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/lindex.test b/tests/lindex.test index b86e2e0..bb3f005 100644 --- a/tests/lindex.test +++ b/tests/lindex.test @@ -79,6 +79,15 @@ test lindex-3.7 {indexes don't shimmer wide ints} { set x [expr {(wide(1)<<31) - 2}] list $x [lindex {1 2 3} $x] [incr x] [incr x] } {2147483646 {} 2147483647 2147483648} +test lindex-3.8 {compiled with static indices out of range, negative} { + list [lindex {a b c} -1] [lindex {a b c} -2] [lindex {a b c} -3] +} [lrepeat 3 {}] +test lindex-3.9 {compiled with calculated indices out of range, negative constant} { + list [lindex {a b c} -1-1] [lindex {a b c} -2+0] [lindex {a b c} -2+1] +} [lrepeat 3 {}] +test lindex-3.10 {compiled with calculated indices out of range, after end} { + list [lindex {a b c} end+1] [lindex {a b c} end+2] [lindex {a b c} end+3] +} [lrepeat 3 {}] # Indices relative to end @@ -432,7 +441,7 @@ test lindex-16.7 {data reuse} { test lindex-17.0 {Bug 1718580} {*}{ -body { lindex {} end foo - } + } -match glob -result {bad index "foo"*} -returnCodes 1 @@ -441,7 +450,7 @@ test lindex-17.0 {Bug 1718580} {*}{ test lindex-17.1 {Bug 1718580} {*}{ -body { lindex a end foo - } + } -match glob -result {bad index "foo"*} -returnCodes 1 diff --git a/tests/link.test b/tests/link.test index 6bff356..a12759d 100644 --- a/tests/link.test +++ b/tests/link.test @@ -173,6 +173,27 @@ test link-2.9 {writing C variables from Tcl} -constraints {testlink} -setup { set uwide 0 concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide } -result {0 5000.0 0 0 0 0 0 0 0 0 0 0 -60.0 0 | 0 5000e 0 0 0 0 0 0 0 0 0 0 -60.00e+ 0} +test link-2.10 {writing C variables from Tcl} -constraints {testlink} -setup { + testlink delete +} -body { + testlink set 43 1.21 4 - 56785678 64 250 30000 60000 0xbaadbeef 12321 32123 3.25 1231231234 + testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 + set int "0x" + set real "0b" + set bool 0 + set string "0" + set wide "0D" + set char "0X" + set uchar "0B" + set short "0D" + set ushort "0x" + set uint "0b" + set long "0d" + set ulong "0X" + set float "0B" + set uwide "0D" + concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide +} -result {0 0.0 0 0 0 0 0 0 0 0 0 0 0.0 0 | 0x 0b 0 0 0D 0X 0B 0D 0x 0b 0d 0X 0B 0D} test link-3.1 {read-only variables} -constraints {testlink} -setup { testlink delete diff --git a/tests/lmap.test b/tests/lmap.test index 08035d9..641eac2 100644 --- a/tests/lmap.test +++ b/tests/lmap.test @@ -220,10 +220,10 @@ test lmap-4.14 {lmap errors} -returnCodes error -body { } -result {list element in braces followed by "3" instead of space} unset -nocomplain a test lmap-4.15 {lmap errors} { - apply {{} { + apply {{} { set a(0) 44 - list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo - }} + list [catch {lmap a {1 2 3} {}} msg o] $msg $::errorInfo + }} } {1 {can't set "a": variable is array} {can't set "a": variable is array while executing "lmap a {1 2 3} {}"}} diff --git a/tests/lrange.test b/tests/lrange.test index 17a757e..3077d91 100644 --- a/tests/lrange.test +++ b/tests/lrange.test @@ -63,7 +63,7 @@ test lrange-1.15 {range of list elements} { } {"a b \{\ "} # emacs highlighting bug workaround --> " test lrange-1.16 {list element quoting} { - lrange {[append a .b]} 0 end + lrange {[append a .b]} 0 end } {{[append} a .b\]} test lrange-2.1 {error conditions} { @@ -90,6 +90,124 @@ test lrange-3.1 {Bug 3588366: end-offsets before start} { lrange $l 0 end-5 }} {1 2 3 4 5} } {} +test lrange-3.2 {compiled with static indices out of range, negative} { + list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3] +} [lrepeat 4 {}] +test lrange-3.3 {compiled with calculated indices out of range, negative constant} { + list [lrange {a b c} 0-1 -1-1] [lrange {a b c} -2+0 0-1] [lrange {a b c} -2-1 -2+1] [lrange {a b c} -2+1 -2-1] +} [lrepeat 4 {}] +test lrange-3.4 {compiled with calculated indices out of range, after end} { + list [lrange {a b c} end+1 end+2] [lrange {a b c} end+2 end+1] [lrange {a b c} end+2 end+3] [lrange {a b c} end+3 end+2] +} [lrepeat 4 {}] + +test lrange-3.5 {compiled with calculated indices, start out of range (negative)} { + list [lrange {a b c} -1 1] [lrange {a b c} -1+0 end-1] [lrange {a b c} -2 1] [lrange {a b c} -2+0 0+1] +} [lrepeat 4 {a b}] +test lrange-3.6 {compiled with calculated indices, end out of range (after end)} { + list [lrange {a b c} 1 end+1] [lrange {a b c} 1+0 2+1] [lrange {a b c} 1 end+1] [lrange {a b c} end-1 3+1] +} [lrepeat 4 {b c}] + +test lrange-4.1 {lrange pure promise} -body { + set ll1 [list $tcl_version 2 3 4] + # Shared + set ll2 $ll1 + # With string rep + string length $ll1 + set rep1 [tcl::unsupported::representation $ll1] + # Get new pure object + set x [lrange $ll1 0 end] + set rep2 [tcl::unsupported::representation $x] + regexp {object pointer at (\S+)} $rep1 -> obj1 + regexp {object pointer at (\S+)} $rep2 -> obj2 + list $rep1 $rep2 [string equal $obj1 $obj2] + # Check for a new clean object +} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0} + +test lrange-4.2 {lrange pure promise} -body { + set ll1 [list $tcl_version 2 3 4] + # Shared + set ll2 $ll1 + # With string rep + string length $ll1 + set rep1 [tcl::unsupported::representation $ll1] + # Get new pure object, not compiled + set x [[string cat l range] $ll1 0 end] + set rep2 [tcl::unsupported::representation $x] + regexp {object pointer at (\S+)} $rep1 -> obj1 + regexp {object pointer at (\S+)} $rep2 -> obj2 + list $rep1 $rep2 [string equal $obj1 $obj2] + # Check for a new clean object +} -match glob -result {*value is *refcount of 3,*, string rep*value is*refcount of 2,* no string rep* 0} + +test lrange-4.3 {lrange pure promise} -body { + set ll1 [list $tcl_version 2 3 4] + # With string rep + string length $ll1 + set rep1 [tcl::unsupported::representation $ll1] + # Get pure object, unshared + set ll2 [lrange $ll1[set ll1 {}] 0 end] + set rep2 [tcl::unsupported::representation $ll2] + regexp {object pointer at (\S+)} $rep1 -> obj1 + regexp {object pointer at (\S+)} $rep2 -> obj2 + list $rep1 $rep2 [string equal $obj1 $obj2] + # Internal optimisations should keep the same object +} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1} + +test lrange-4.4 {lrange pure promise} -body { + set ll1 [list $tcl_version 2 3 4] + # With string rep + string length $ll1 + set rep1 [tcl::unsupported::representation $ll1] + # Get pure object, unshared, not compiled + set ll2 [[string cat l range] $ll1[set ll1 {}] 0 end] + set rep2 [tcl::unsupported::representation $ll2] + regexp {object pointer at (\S+)} $rep1 -> obj1 + regexp {object pointer at (\S+)} $rep2 -> obj2 + list $rep1 $rep2 [string equal $obj1 $obj2] + # Internal optimisations should keep the same object +} -match glob -result {*value is *refcount of 2,*, string rep*value is*refcount of 2,* no string rep* 1} + +# Testing for compiled vs non-compiled behaviour, and shared vs non-shared. +# Far too many variations to check with spelt-out tests. +# Note that this *just* checks whether the different versions are the same +# not whether any of them is correct. +apply {{} { + set lss {{} {a} {a b c} {a b c d}} + set idxs {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2} + set lrange lrange + + foreach ls $lss { + foreach a $idxs { + foreach b $idxs { + # Shared, uncompiled + set ls2 $ls + set expected [list [catch {$lrange $ls $a $b} m] $m] + # Shared, compiled + set tester [list lrange $ls $a $b] + set script [list catch $tester m] + set script "list \[$script\] \$m" + test lrange-5.[incr n].1 {lrange shared compiled} \ + [list apply [list {} $script]] $expected + # Unshared, uncompiled + set tester [string map [list %l [list $ls] %a $a %b $b] { + [string cat l range] [lrange %l 0 end] %a %b + }] + set script [list catch $tester m] + set script "list \[$script\] \$m" + test lrange-5.$n.2 {lrange unshared uncompiled} \ + [list apply [list {} $script]] $expected + # Unshared, compiled + set tester [string map [list %l [list $ls] %a $a %b $b] { + lrange [lrange %l 0 end] %a %b + }] + set script [list catch $tester m] + set script "list \[$script\] \$m" + test lrange-5.$n.3 {lrange unshared compiled} \ + [list apply [list {} $script]] $expected + } + } + } +}} # cleanup ::tcltest::cleanupTests diff --git a/tests/lrepeat.test b/tests/lrepeat.test index 788bb9b..e89f1b7 100644 --- a/tests/lrepeat.test +++ b/tests/lrepeat.test @@ -40,7 +40,7 @@ test lrepeat-1.4 {error cases} { lrepeat -3 1 } -returnCodes 1 - -result {bad count "-3": must be integer >= 0} + -result {bad count "-3": must be integer >= 0} } test lrepeat-1.5 {Accept zero repetitions (TIP 323)} { -body { @@ -53,7 +53,7 @@ test lrepeat-1.6 {error cases} { lrepeat 3.5 1 } -returnCodes 1 - -result {expected integer but got "3.5"} + -result {expected integer but got "3.5"} } test lrepeat-1.7 {Accept zero repetitions (TIP 323)} { -body { diff --git a/tests/lreplace.test b/tests/lreplace.test index d7f8226..fd2f7f8 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -98,12 +98,18 @@ test lreplace-1.26 {lreplace command} { [set foo [lreplace $foo end end]] \ [set foo [lreplace $foo end end]] } {a {} {}} -test lreplace-1.27 {lreplace command} { +test lreplace-1.27 {lreplace command} -body { lreplace x 1 1 -} x -test lreplace-1.28 {lreplace command} { +} -result x +test lreplace-1.28 {lreplace command} -body { lreplace x 1 1 y -} {x y} +} -result {x y} +test lreplace-1.29 {lreplace command} -body { + lreplace x 1 1 [error foo] +} -returnCodes 1 -result {foo} +test lreplace-1.30 {lreplace command} -body { + lreplace {not {}alist} 0 0 [error foo] +} -returnCodes 1 -result {foo} test lreplace-2.1 {lreplace errors} { list [catch lreplace msg] $msg @@ -122,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/lsearch.test b/tests/lsearch.test index f36e987..e401581 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -59,7 +59,7 @@ test lsearch-2.9 {search modes} { } 1 test lsearch-2.10 {search modes} -returnCodes error -body { lsearch -glib {b.x bx xy bcx} b.x -} -result {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices} +} -result {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices} test lsearch-2.11 {search modes with -nocase} { lsearch -exact -nocase {a b c A B C} A } 0 @@ -87,10 +87,10 @@ test lsearch-3.2 {lsearch errors} -returnCodes error -body { } -result {wrong # args: should be "lsearch ?-option value ...? list pattern"} test lsearch-3.3 {lsearch errors} -returnCodes error -body { lsearch a b c -} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices} +} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices} test lsearch-3.4 {lsearch errors} -returnCodes error -body { lsearch a b c d -} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices} +} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices} test lsearch-3.5 {lsearch errors} -returnCodes error -body { lsearch "\{" b } -result {unmatched open brace in list} @@ -404,20 +404,48 @@ test lsearch-17.2 {lsearch -index option, basic functionality} { lsearch -index 1 -exact {{a c} {a b} {a a}} a } 2 test lsearch-17.3 {lsearch -index option, basic functionality} { - lsearch -index 1 -glob {{ab cb} {ab bb} {ab ab}} b* + lsearch -index 1 -glob {{ab cb} {ab bb} {ab ab}} b* } 1 test lsearch-17.4 {lsearch -index option, basic functionality} { lsearch -index 1 -regexp {{ab cb} {ab bb} {ab ab}} {[cb]b} -} 0 +} 0 test lsearch-17.5 {lsearch -index option, basic functionality} { lsearch -all -index 0 -exact {{a c} {a b} {d a}} a } {0 1} test lsearch-17.6 {lsearch -index option, basic functionality} { - lsearch -all -index 1 -glob {{ab cb} {ab bb} {db bx}} b* + lsearch -all -index 1 -glob {{ab cb} {ab bb} {db bx}} b* } {1 2} test lsearch-17.7 {lsearch -index option, basic functionality} { lsearch -all -index 1 -regexp {{ab cb} {ab bb} {ab ab}} {[cb]b} } {0 1} +test lsearch-17.8 {lsearch -index option, empty argument} { + lsearch -index {} a a +} 0 +test lsearch-17.9 {lsearch -index option, empty argument} { + lsearch -index {} a a +} [lsearch a a] +test lsearch-17.10 {lsearch -index option, empty argument} { + lsearch -index {} [list \{] \{ +} 0 +test lsearch-17.11 {lsearch -index option, empty argument} { + lsearch -index {} [list \{] \{ +} [lsearch [list \{] \{] +test lsearch-17.12 {lsearch -index option, encoding aliasing} -body { + lsearch -index -2 a a +} -returnCodes error -result {index "-2" cannot select an element from any list} +test lsearch-17.13 {lsearch -index option, encoding aliasing} -body { + lsearch -index -1-1 a a +} -returnCodes error -result {index "-1-1" cannot select an element from any list} +test lsearch-17.14 {lsearch -index option, encoding aliasing} -body { + lsearch -index end--1 a a +} -returnCodes error -result {index "end--1" cannot select an element from any list} +test lsearch-17.15 {lsearch -index option, encoding aliasing} -body { + lsearch -index end+1 a a +} -returnCodes error -result {index "end+1" cannot select an element from any list} +test lsearch-17.16 {lsearch -index option, encoding aliasing} -body { + lsearch -index end+2 a a +} -returnCodes error -result {index "end+2" cannot select an element from any list} + test lsearch-18.1 {lsearch -index option, list as index basic functionality} { lsearch -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a @@ -426,30 +454,39 @@ test lsearch-18.2 {lsearch -index option, list as index basic functionality} { lsearch -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a } 0 test lsearch-18.3 {lsearch -index option, list as index basic functionality} { - lsearch -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b* + lsearch -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b* } 0 test lsearch-18.4 {lsearch -index option, list as index basic functionality} { lsearch -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b} -} 0 +} 0 test lsearch-18.5 {lsearch -index option, list as index basic functionality} { lsearch -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a } {0 1} -test lsearch-19.1 {lsearch -sunindices option} { +test lsearch-19.1 {lsearch -subindices option} { lsearch -subindices -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a } {1 0 0} -test lsearch-19.2 {lsearch -sunindices option} { +test lsearch-19.2 {lsearch -subindices option} { lsearch -subindices -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a } {0 2 0} -test lsearch-19.3 {lsearch -sunindices option} { - lsearch -subindices -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b* +test lsearch-19.3 {lsearch -subindices option} { + lsearch -subindices -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b* } {0 1 1} -test lsearch-19.4 {lsearch -sunindices option} { +test lsearch-19.4 {lsearch -subindices option} { lsearch -subindices -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b} -} {0 0 1} -test lsearch-19.5 {lsearch -sunindices option} { +} {0 0 1} +test lsearch-19.5 {lsearch -subindices option} { lsearch -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a } {{0 0 0} {1 0 0}} +test lsearch-19.6 {lsearch -subindices option} { + lsearch -subindices -all -index {1 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a +} {{0 1 0} {1 1 0}} +test lsearch-19.7 {lsearch -subindices option} { + lsearch -subindices -index end {{1 a}} a +} {0 1} +test lsearch-19.8 {lsearch -subindices option} { + lsearch -subindices -all -index end {{1 a}} a +} {{0 1}} test lsearch-20.1 {lsearch -index option, index larger than sublists} -body { lsearch -index 2 {{a c} {a b} {a a}} a @@ -509,6 +546,149 @@ test lsearch-22.5 {lsearch -bisect, all equal} { test lsearch-22.6 {lsearch -sorted, all equal} { lsearch -sorted -integer {5 5 5 5} 5 } {0} + +test lsearch-23.1 {lsearch -stride option, errors} -body { + lsearch -stride {a b} a +} -returnCodes error -result {"-stride" option must be followed by stride length} +test lsearch-23.2 {lsearch -stride option, errors} -body { + lsearch -stride 0 {a b} a +} -returnCodes error -result {stride length must be at least 1} +test lsearch-23.3 {lsearch -stride option, errors} -body { + lsearch -stride 2 {a b c} a +} -returnCodes error -result {list size must be a multiple of the stride length} +test lsearch-23.4 {lsearch -stride option, errors} -body { + lsearch -stride 5 {a b c} a +} -returnCodes error -result {list size must be a multiple of the stride length} +test lsearch-23.5 {lsearch -stride option, errors} -body { + # Stride equal to length is ok + lsearch -stride 3 {a b c} a +} -result 0 + +test lsearch-24.1 {lsearch -stride option} -body { + lsearch -stride 2 {a b c d e f g h} d +} -result -1 +test lsearch-24.2 {lsearch -stride option} -body { + lsearch -stride 2 {a b c d e f g h} e +} -result 4 +test lsearch-24.3 {lsearch -stride option} -body { + lsearch -stride 3 {a b c d e f g h i} e +} -result -1 +test lsearch-24.4 {lsearch -stride option} -body { + # Result points first in group + lsearch -stride 3 -index 1 {a b c d e f g h i} e +} -result 3 +test lsearch-24.5 {lsearch -stride option} -body { + lsearch -inline -stride 2 {a b c d e f g h} d +} -result {} +test lsearch-24.6 {lsearch -stride option} -body { + # Inline result is a "single element" strided list + lsearch -inline -stride 2 {a b c d e f g h} e +} -result "e f" +test lsearch-24.7 {lsearch -stride option} -body { + lsearch -inline -stride 3 {a b c d e f g h i} e +} -result {} +test lsearch-24.8 {lsearch -stride option} -body { + lsearch -inline -stride 3 -index 1 {a b c d e f g h i} e +} -result "d e f" +test lsearch-24.9 {lsearch -stride option} -body { + lsearch -all -inline -stride 3 -index 1 {a b c d e f g e i} e +} -result "d e f g e i" +test lsearch-24.10 {lsearch -stride option} -body { + lsearch -all -inline -stride 3 -index 0 {a b c d e f a e i} a +} -result "a b c a e i" +test lsearch-24.11 {lsearch -stride option} -body { + # Stride 1 is same as no stride + lsearch -stride 1 {a b c d e f g h} d +} -result 3 + +# 25* mimics 19* but with -inline added to -subindices +test lsearch-25.1 {lsearch -subindices option} { + lsearch -inline -subindices -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a +} {a} +test lsearch-25.2 {lsearch -subindices option} { + lsearch -inline -subindices -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a +} {a} +test lsearch-25.3 {lsearch -subindices option} { + lsearch -inline -subindices -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b* +} {bb} +test lsearch-25.4 {lsearch -subindices option} { + lsearch -inline -subindices -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b} +} {cb} +test lsearch-25.5 {lsearch -subindices option} { + lsearch -inline -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a +} {a a} +test lsearch-25.6 {lsearch -subindices option} { + lsearch -inline -subindices -all -index {1 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a +} {a a} + +# 26* mimics 19* but with -stride added +test lsearch-26.1 {lsearch -stride + -subindices option} { + lsearch -stride 3 -subindices -index {0 0} {{x x} {x b} {a d} {a c} {a b} {a a}} a +} {3 0} +test lsearch-26.2 {lsearch -stride + -subindices option} { + lsearch -stride 3 -subindices -index {2 0} -exact {{x x} {x b} {a d} {a c} {a b} {a a}} a +} {2 0} +test lsearch-26.3 {lsearch -stride + -subindices option} { + lsearch -stride 3 -subindices -index {1 1} -glob {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} b* +} {1 1} +test lsearch-26.4 {lsearch -stride + -subindices option} { + lsearch -stride 3 -subindices -index {0 1} -regexp {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} {[cb]b} +} {0 1} +test lsearch-26.5 {lsearch -stride + -subindices option} { + lsearch -stride 3 -subindices -all -index {0 0} -exact {{a c} {a b} {d a} {a c} {a b} {d a}} a +} {{0 0} {3 0}} +test lsearch-26.6 {lsearch -stride + -subindices option} { + lsearch -stride 3 -subindices -all -index {1 0} -exact {{a c} {a b} {d a} {x c} {a b} {d a}} a +} {{1 0} {4 0}} + +# 27* mimics 25* but with -stride added +test lsearch-27.1 {lsearch -stride + -subindices option} { + lsearch -inline -stride 3 -subindices -index {0 0} {{x x} {x b} {a d} {a c} {a b} {a a}} a +} {a} +test lsearch-27.2 {lsearch -stride + -subindices option} { + lsearch -inline -stride 3 -subindices -index {2 0} -exact {{x x} {x b} {a d} {a c} {a b} {a a}} a +} {a} +test lsearch-27.3 {lsearch -stride + -subindices option} { + lsearch -inline -stride 3 -subindices -index {1 1} -glob {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} b* +} {bb} +test lsearch-27.4 {lsearch -stride + -subindices option} { + lsearch -inline -stride 3 -subindices -index {0 1} -regexp {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} {[cb]b} +} {cb} +test lsearch-27.5 {lsearch -stride + -subindices option} { + lsearch -inline -stride 3 -subindices -all -index {0 0} -exact {{a c} {a b} {d a} {a c} {a b} {d a}} a +} {a a} +test lsearch-27.6 {lsearch -stride + -subindices option} { + lsearch -inline -stride 3 -subindices -all -index {1 0} -exact {{a c} {a b} {d a} {x c} {a b} {d a}} a +} {a a} + +test lsearch-28.1 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 {5 3 7 8 9 2} 5 +} -result 0 +test lsearch-28.2 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 {5 3 7 8 9 2} 3 +} -result -1 +test lsearch-28.3 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 {5 3 7 8 9 2} 7 +} -result 2 +test lsearch-28.4 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 {5 3 7 8 9 2} 8 +} -result -1 +test lsearch-28.5 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 {5 3 7 8 9 2} 9 +} -result 4 +test lsearch-28.6 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 {5 3 7 8 9 2} 2 +} -result -1 +test lsearch-28.7 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 -index 0 -subindices {5 3 7 8 9 2} 9 +} -result 4 +test lsearch-28.8 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 -index 1 -subindices {3 5 8 7 2 9} 9 +} -result 5 +test lsearch-28.9 {lsearch -sorted with -stride} -body { + lsearch -sorted -stride 2 -index 1 -subindices -inline {3 5 8 7 2 9} 9 +} -result 9 + # cleanup catch {unset res} diff --git a/tests/lsetComp.test b/tests/lsetComp.test index 6846cbf..6330de4 100644..100755 --- a/tests/lsetComp.test +++ b/tests/lsetComp.test @@ -22,7 +22,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { proc evalInProc { script } { proc testProc {} $script set status [catch { - testProc + testProc } result] rename testProc {} return [list $status $result] @@ -60,69 +60,69 @@ test lsetComp-2.3 {lset, compiled, list of args, scalar, one-byte offset} { test lsetComp-2.4 {lset, compiled, list of args, scalar, four-byte offset} { evalInProc { - set x0 0; set x1 0; set x2 0; set x3 0; - set x4 0; set x5 0; set x6 0; set x7 0; - set x8 0; set x9 0; set x10 0; set x11 0; - set x12 0; set x13 0; set x14 0; set x15 0; - set x16 0; set x17 0; set x18 0; set x19 0; - set x20 0; set x21 0; set x22 0; set x23 0; - set x24 0; set x25 0; set x26 0; set x27 0; - set x28 0; set x29 0; set x30 0; set x31 0; - set x32 0; set x33 0; set x34 0; set x35 0; - set x36 0; set x37 0; set x38 0; set x39 0; - set x40 0; set x41 0; set x42 0; set x43 0; - set x44 0; set x45 0; set x46 0; set x47 0; - set x48 0; set x49 0; set x50 0; set x51 0; - set x52 0; set x53 0; set x54 0; set x55 0; - set x56 0; set x57 0; set x58 0; set x59 0; - set x60 0; set x61 0; set x62 0; set x63 0; - set x64 0; set x65 0; set x66 0; set x67 0; - set x68 0; set x69 0; set x70 0; set x71 0; - set x72 0; set x73 0; set x74 0; set x75 0; - set x76 0; set x77 0; set x78 0; set x79 0; - set x80 0; set x81 0; set x82 0; set x83 0; - set x84 0; set x85 0; set x86 0; set x87 0; - set x88 0; set x89 0; set x90 0; set x91 0; - set x92 0; set x93 0; set x94 0; set x95 0; - set x96 0; set x97 0; set x98 0; set x99 0; - set x100 0; set x101 0; set x102 0; set x103 0; - set x104 0; set x105 0; set x106 0; set x107 0; - set x108 0; set x109 0; set x110 0; set x111 0; - set x112 0; set x113 0; set x114 0; set x115 0; - set x116 0; set x117 0; set x118 0; set x119 0; - set x120 0; set x121 0; set x122 0; set x123 0; - set x124 0; set x125 0; set x126 0; set x127 0; - set x128 0; set x129 0; set x130 0; set x131 0; - set x132 0; set x133 0; set x134 0; set x135 0; - set x136 0; set x137 0; set x138 0; set x139 0; - set x140 0; set x141 0; set x142 0; set x143 0; - set x144 0; set x145 0; set x146 0; set x147 0; - set x148 0; set x149 0; set x150 0; set x151 0; - set x152 0; set x153 0; set x154 0; set x155 0; - set x156 0; set x157 0; set x158 0; set x159 0; - set x160 0; set x161 0; set x162 0; set x163 0; - set x164 0; set x165 0; set x166 0; set x167 0; - set x168 0; set x169 0; set x170 0; set x171 0; - set x172 0; set x173 0; set x174 0; set x175 0; - set x176 0; set x177 0; set x178 0; set x179 0; - set x180 0; set x181 0; set x182 0; set x183 0; - set x184 0; set x185 0; set x186 0; set x187 0; - set x188 0; set x189 0; set x190 0; set x191 0; - set x192 0; set x193 0; set x194 0; set x195 0; - set x196 0; set x197 0; set x198 0; set x199 0; - set x200 0; set x201 0; set x202 0; set x203 0; - set x204 0; set x205 0; set x206 0; set x207 0; - set x208 0; set x209 0; set x210 0; set x211 0; - set x212 0; set x213 0; set x214 0; set x215 0; - set x216 0; set x217 0; set x218 0; set x219 0; - set x220 0; set x221 0; set x222 0; set x223 0; - set x224 0; set x225 0; set x226 0; set x227 0; - set x228 0; set x229 0; set x230 0; set x231 0; - set x232 0; set x233 0; set x234 0; set x235 0; - set x236 0; set x237 0; set x238 0; set x239 0; - set x240 0; set x241 0; set x242 0; set x243 0; - set x244 0; set x245 0; set x246 0; set x247 0; - set x248 0; set x249 0; set x250 0; set x251 0; + set x0 0; set x1 0; set x2 0; set x3 0; + set x4 0; set x5 0; set x6 0; set x7 0; + set x8 0; set x9 0; set x10 0; set x11 0; + set x12 0; set x13 0; set x14 0; set x15 0; + set x16 0; set x17 0; set x18 0; set x19 0; + set x20 0; set x21 0; set x22 0; set x23 0; + set x24 0; set x25 0; set x26 0; set x27 0; + set x28 0; set x29 0; set x30 0; set x31 0; + set x32 0; set x33 0; set x34 0; set x35 0; + set x36 0; set x37 0; set x38 0; set x39 0; + set x40 0; set x41 0; set x42 0; set x43 0; + set x44 0; set x45 0; set x46 0; set x47 0; + set x48 0; set x49 0; set x50 0; set x51 0; + set x52 0; set x53 0; set x54 0; set x55 0; + set x56 0; set x57 0; set x58 0; set x59 0; + set x60 0; set x61 0; set x62 0; set x63 0; + set x64 0; set x65 0; set x66 0; set x67 0; + set x68 0; set x69 0; set x70 0; set x71 0; + set x72 0; set x73 0; set x74 0; set x75 0; + set x76 0; set x77 0; set x78 0; set x79 0; + set x80 0; set x81 0; set x82 0; set x83 0; + set x84 0; set x85 0; set x86 0; set x87 0; + set x88 0; set x89 0; set x90 0; set x91 0; + set x92 0; set x93 0; set x94 0; set x95 0; + set x96 0; set x97 0; set x98 0; set x99 0; + set x100 0; set x101 0; set x102 0; set x103 0; + set x104 0; set x105 0; set x106 0; set x107 0; + set x108 0; set x109 0; set x110 0; set x111 0; + set x112 0; set x113 0; set x114 0; set x115 0; + set x116 0; set x117 0; set x118 0; set x119 0; + set x120 0; set x121 0; set x122 0; set x123 0; + set x124 0; set x125 0; set x126 0; set x127 0; + set x128 0; set x129 0; set x130 0; set x131 0; + set x132 0; set x133 0; set x134 0; set x135 0; + set x136 0; set x137 0; set x138 0; set x139 0; + set x140 0; set x141 0; set x142 0; set x143 0; + set x144 0; set x145 0; set x146 0; set x147 0; + set x148 0; set x149 0; set x150 0; set x151 0; + set x152 0; set x153 0; set x154 0; set x155 0; + set x156 0; set x157 0; set x158 0; set x159 0; + set x160 0; set x161 0; set x162 0; set x163 0; + set x164 0; set x165 0; set x166 0; set x167 0; + set x168 0; set x169 0; set x170 0; set x171 0; + set x172 0; set x173 0; set x174 0; set x175 0; + set x176 0; set x177 0; set x178 0; set x179 0; + set x180 0; set x181 0; set x182 0; set x183 0; + set x184 0; set x185 0; set x186 0; set x187 0; + set x188 0; set x189 0; set x190 0; set x191 0; + set x192 0; set x193 0; set x194 0; set x195 0; + set x196 0; set x197 0; set x198 0; set x199 0; + set x200 0; set x201 0; set x202 0; set x203 0; + set x204 0; set x205 0; set x206 0; set x207 0; + set x208 0; set x209 0; set x210 0; set x211 0; + set x212 0; set x213 0; set x214 0; set x215 0; + set x216 0; set x217 0; set x218 0; set x219 0; + set x220 0; set x221 0; set x222 0; set x223 0; + set x224 0; set x225 0; set x226 0; set x227 0; + set x228 0; set x229 0; set x230 0; set x231 0; + set x232 0; set x233 0; set x234 0; set x235 0; + set x236 0; set x237 0; set x238 0; set x239 0; + set x240 0; set x241 0; set x242 0; set x243 0; + set x244 0; set x245 0; set x246 0; set x247 0; + set x248 0; set x249 0; set x250 0; set x251 0; set x252 0; set x253 0; set x254 0; set x255 0; set x {{1 2} {3 4}} lset x {1 1} 5 @@ -145,69 +145,69 @@ test lsetComp-2.6 {lset, compiled, list of args, array, one-byte offset} { test lsetComp-2.7 {lset, compiled, list of args, array, four-byte offset} { evalInProc { - set x0 0; set x1 0; set x2 0; set x3 0; - set x4 0; set x5 0; set x6 0; set x7 0; - set x8 0; set x9 0; set x10 0; set x11 0; - set x12 0; set x13 0; set x14 0; set x15 0; - set x16 0; set x17 0; set x18 0; set x19 0; - set x20 0; set x21 0; set x22 0; set x23 0; - set x24 0; set x25 0; set x26 0; set x27 0; - set x28 0; set x29 0; set x30 0; set x31 0; - set x32 0; set x33 0; set x34 0; set x35 0; - set x36 0; set x37 0; set x38 0; set x39 0; - set x40 0; set x41 0; set x42 0; set x43 0; - set x44 0; set x45 0; set x46 0; set x47 0; - set x48 0; set x49 0; set x50 0; set x51 0; - set x52 0; set x53 0; set x54 0; set x55 0; - set x56 0; set x57 0; set x58 0; set x59 0; - set x60 0; set x61 0; set x62 0; set x63 0; - set x64 0; set x65 0; set x66 0; set x67 0; - set x68 0; set x69 0; set x70 0; set x71 0; - set x72 0; set x73 0; set x74 0; set x75 0; - set x76 0; set x77 0; set x78 0; set x79 0; - set x80 0; set x81 0; set x82 0; set x83 0; - set x84 0; set x85 0; set x86 0; set x87 0; - set x88 0; set x89 0; set x90 0; set x91 0; - set x92 0; set x93 0; set x94 0; set x95 0; - set x96 0; set x97 0; set x98 0; set x99 0; - set x100 0; set x101 0; set x102 0; set x103 0; - set x104 0; set x105 0; set x106 0; set x107 0; - set x108 0; set x109 0; set x110 0; set x111 0; - set x112 0; set x113 0; set x114 0; set x115 0; - set x116 0; set x117 0; set x118 0; set x119 0; - set x120 0; set x121 0; set x122 0; set x123 0; - set x124 0; set x125 0; set x126 0; set x127 0; - set x128 0; set x129 0; set x130 0; set x131 0; - set x132 0; set x133 0; set x134 0; set x135 0; - set x136 0; set x137 0; set x138 0; set x139 0; - set x140 0; set x141 0; set x142 0; set x143 0; - set x144 0; set x145 0; set x146 0; set x147 0; - set x148 0; set x149 0; set x150 0; set x151 0; - set x152 0; set x153 0; set x154 0; set x155 0; - set x156 0; set x157 0; set x158 0; set x159 0; - set x160 0; set x161 0; set x162 0; set x163 0; - set x164 0; set x165 0; set x166 0; set x167 0; - set x168 0; set x169 0; set x170 0; set x171 0; - set x172 0; set x173 0; set x174 0; set x175 0; - set x176 0; set x177 0; set x178 0; set x179 0; - set x180 0; set x181 0; set x182 0; set x183 0; - set x184 0; set x185 0; set x186 0; set x187 0; - set x188 0; set x189 0; set x190 0; set x191 0; - set x192 0; set x193 0; set x194 0; set x195 0; - set x196 0; set x197 0; set x198 0; set x199 0; - set x200 0; set x201 0; set x202 0; set x203 0; - set x204 0; set x205 0; set x206 0; set x207 0; - set x208 0; set x209 0; set x210 0; set x211 0; - set x212 0; set x213 0; set x214 0; set x215 0; - set x216 0; set x217 0; set x218 0; set x219 0; - set x220 0; set x221 0; set x222 0; set x223 0; - set x224 0; set x225 0; set x226 0; set x227 0; - set x228 0; set x229 0; set x230 0; set x231 0; - set x232 0; set x233 0; set x234 0; set x235 0; - set x236 0; set x237 0; set x238 0; set x239 0; - set x240 0; set x241 0; set x242 0; set x243 0; - set x244 0; set x245 0; set x246 0; set x247 0; - set x248 0; set x249 0; set x250 0; set x251 0; + set x0 0; set x1 0; set x2 0; set x3 0; + set x4 0; set x5 0; set x6 0; set x7 0; + set x8 0; set x9 0; set x10 0; set x11 0; + set x12 0; set x13 0; set x14 0; set x15 0; + set x16 0; set x17 0; set x18 0; set x19 0; + set x20 0; set x21 0; set x22 0; set x23 0; + set x24 0; set x25 0; set x26 0; set x27 0; + set x28 0; set x29 0; set x30 0; set x31 0; + set x32 0; set x33 0; set x34 0; set x35 0; + set x36 0; set x37 0; set x38 0; set x39 0; + set x40 0; set x41 0; set x42 0; set x43 0; + set x44 0; set x45 0; set x46 0; set x47 0; + set x48 0; set x49 0; set x50 0; set x51 0; + set x52 0; set x53 0; set x54 0; set x55 0; + set x56 0; set x57 0; set x58 0; set x59 0; + set x60 0; set x61 0; set x62 0; set x63 0; + set x64 0; set x65 0; set x66 0; set x67 0; + set x68 0; set x69 0; set x70 0; set x71 0; + set x72 0; set x73 0; set x74 0; set x75 0; + set x76 0; set x77 0; set x78 0; set x79 0; + set x80 0; set x81 0; set x82 0; set x83 0; + set x84 0; set x85 0; set x86 0; set x87 0; + set x88 0; set x89 0; set x90 0; set x91 0; + set x92 0; set x93 0; set x94 0; set x95 0; + set x96 0; set x97 0; set x98 0; set x99 0; + set x100 0; set x101 0; set x102 0; set x103 0; + set x104 0; set x105 0; set x106 0; set x107 0; + set x108 0; set x109 0; set x110 0; set x111 0; + set x112 0; set x113 0; set x114 0; set x115 0; + set x116 0; set x117 0; set x118 0; set x119 0; + set x120 0; set x121 0; set x122 0; set x123 0; + set x124 0; set x125 0; set x126 0; set x127 0; + set x128 0; set x129 0; set x130 0; set x131 0; + set x132 0; set x133 0; set x134 0; set x135 0; + set x136 0; set x137 0; set x138 0; set x139 0; + set x140 0; set x141 0; set x142 0; set x143 0; + set x144 0; set x145 0; set x146 0; set x147 0; + set x148 0; set x149 0; set x150 0; set x151 0; + set x152 0; set x153 0; set x154 0; set x155 0; + set x156 0; set x157 0; set x158 0; set x159 0; + set x160 0; set x161 0; set x162 0; set x163 0; + set x164 0; set x165 0; set x166 0; set x167 0; + set x168 0; set x169 0; set x170 0; set x171 0; + set x172 0; set x173 0; set x174 0; set x175 0; + set x176 0; set x177 0; set x178 0; set x179 0; + set x180 0; set x181 0; set x182 0; set x183 0; + set x184 0; set x185 0; set x186 0; set x187 0; + set x188 0; set x189 0; set x190 0; set x191 0; + set x192 0; set x193 0; set x194 0; set x195 0; + set x196 0; set x197 0; set x198 0; set x199 0; + set x200 0; set x201 0; set x202 0; set x203 0; + set x204 0; set x205 0; set x206 0; set x207 0; + set x208 0; set x209 0; set x210 0; set x211 0; + set x212 0; set x213 0; set x214 0; set x215 0; + set x216 0; set x217 0; set x218 0; set x219 0; + set x220 0; set x221 0; set x222 0; set x223 0; + set x224 0; set x225 0; set x226 0; set x227 0; + set x228 0; set x229 0; set x230 0; set x231 0; + set x232 0; set x233 0; set x234 0; set x235 0; + set x236 0; set x237 0; set x238 0; set x239 0; + set x240 0; set x241 0; set x242 0; set x243 0; + set x244 0; set x245 0; set x246 0; set x247 0; + set x248 0; set x249 0; set x250 0; set x251 0; set x252 0; set x253 0; set x254 0; set x255 0; set y(0) {{1 2} {3 4}} lset y(0) {1 1} 5 @@ -253,69 +253,69 @@ test lsetComp-3.3 {lset, compiled, flat args, scalar, one-byte offset} { test lsetComp-3.4 {lset, compiled, scalar, four-byte offset} { evalInProc { - set x0 0; set x1 0; set x2 0; set x3 0; - set x4 0; set x5 0; set x6 0; set x7 0; - set x8 0; set x9 0; set x10 0; set x11 0; - set x12 0; set x13 0; set x14 0; set x15 0; - set x16 0; set x17 0; set x18 0; set x19 0; - set x20 0; set x21 0; set x22 0; set x23 0; - set x24 0; set x25 0; set x26 0; set x27 0; - set x28 0; set x29 0; set x30 0; set x31 0; - set x32 0; set x33 0; set x34 0; set x35 0; - set x36 0; set x37 0; set x38 0; set x39 0; - set x40 0; set x41 0; set x42 0; set x43 0; - set x44 0; set x45 0; set x46 0; set x47 0; - set x48 0; set x49 0; set x50 0; set x51 0; - set x52 0; set x53 0; set x54 0; set x55 0; - set x56 0; set x57 0; set x58 0; set x59 0; - set x60 0; set x61 0; set x62 0; set x63 0; - set x64 0; set x65 0; set x66 0; set x67 0; - set x68 0; set x69 0; set x70 0; set x71 0; - set x72 0; set x73 0; set x74 0; set x75 0; - set x76 0; set x77 0; set x78 0; set x79 0; - set x80 0; set x81 0; set x82 0; set x83 0; - set x84 0; set x85 0; set x86 0; set x87 0; - set x88 0; set x89 0; set x90 0; set x91 0; - set x92 0; set x93 0; set x94 0; set x95 0; - set x96 0; set x97 0; set x98 0; set x99 0; - set x100 0; set x101 0; set x102 0; set x103 0; - set x104 0; set x105 0; set x106 0; set x107 0; - set x108 0; set x109 0; set x110 0; set x111 0; - set x112 0; set x113 0; set x114 0; set x115 0; - set x116 0; set x117 0; set x118 0; set x119 0; - set x120 0; set x121 0; set x122 0; set x123 0; - set x124 0; set x125 0; set x126 0; set x127 0; - set x128 0; set x129 0; set x130 0; set x131 0; - set x132 0; set x133 0; set x134 0; set x135 0; - set x136 0; set x137 0; set x138 0; set x139 0; - set x140 0; set x141 0; set x142 0; set x143 0; - set x144 0; set x145 0; set x146 0; set x147 0; - set x148 0; set x149 0; set x150 0; set x151 0; - set x152 0; set x153 0; set x154 0; set x155 0; - set x156 0; set x157 0; set x158 0; set x159 0; - set x160 0; set x161 0; set x162 0; set x163 0; - set x164 0; set x165 0; set x166 0; set x167 0; - set x168 0; set x169 0; set x170 0; set x171 0; - set x172 0; set x173 0; set x174 0; set x175 0; - set x176 0; set x177 0; set x178 0; set x179 0; - set x180 0; set x181 0; set x182 0; set x183 0; - set x184 0; set x185 0; set x186 0; set x187 0; - set x188 0; set x189 0; set x190 0; set x191 0; - set x192 0; set x193 0; set x194 0; set x195 0; - set x196 0; set x197 0; set x198 0; set x199 0; - set x200 0; set x201 0; set x202 0; set x203 0; - set x204 0; set x205 0; set x206 0; set x207 0; - set x208 0; set x209 0; set x210 0; set x211 0; - set x212 0; set x213 0; set x214 0; set x215 0; - set x216 0; set x217 0; set x218 0; set x219 0; - set x220 0; set x221 0; set x222 0; set x223 0; - set x224 0; set x225 0; set x226 0; set x227 0; - set x228 0; set x229 0; set x230 0; set x231 0; - set x232 0; set x233 0; set x234 0; set x235 0; - set x236 0; set x237 0; set x238 0; set x239 0; - set x240 0; set x241 0; set x242 0; set x243 0; - set x244 0; set x245 0; set x246 0; set x247 0; - set x248 0; set x249 0; set x250 0; set x251 0; + set x0 0; set x1 0; set x2 0; set x3 0; + set x4 0; set x5 0; set x6 0; set x7 0; + set x8 0; set x9 0; set x10 0; set x11 0; + set x12 0; set x13 0; set x14 0; set x15 0; + set x16 0; set x17 0; set x18 0; set x19 0; + set x20 0; set x21 0; set x22 0; set x23 0; + set x24 0; set x25 0; set x26 0; set x27 0; + set x28 0; set x29 0; set x30 0; set x31 0; + set x32 0; set x33 0; set x34 0; set x35 0; + set x36 0; set x37 0; set x38 0; set x39 0; + set x40 0; set x41 0; set x42 0; set x43 0; + set x44 0; set x45 0; set x46 0; set x47 0; + set x48 0; set x49 0; set x50 0; set x51 0; + set x52 0; set x53 0; set x54 0; set x55 0; + set x56 0; set x57 0; set x58 0; set x59 0; + set x60 0; set x61 0; set x62 0; set x63 0; + set x64 0; set x65 0; set x66 0; set x67 0; + set x68 0; set x69 0; set x70 0; set x71 0; + set x72 0; set x73 0; set x74 0; set x75 0; + set x76 0; set x77 0; set x78 0; set x79 0; + set x80 0; set x81 0; set x82 0; set x83 0; + set x84 0; set x85 0; set x86 0; set x87 0; + set x88 0; set x89 0; set x90 0; set x91 0; + set x92 0; set x93 0; set x94 0; set x95 0; + set x96 0; set x97 0; set x98 0; set x99 0; + set x100 0; set x101 0; set x102 0; set x103 0; + set x104 0; set x105 0; set x106 0; set x107 0; + set x108 0; set x109 0; set x110 0; set x111 0; + set x112 0; set x113 0; set x114 0; set x115 0; + set x116 0; set x117 0; set x118 0; set x119 0; + set x120 0; set x121 0; set x122 0; set x123 0; + set x124 0; set x125 0; set x126 0; set x127 0; + set x128 0; set x129 0; set x130 0; set x131 0; + set x132 0; set x133 0; set x134 0; set x135 0; + set x136 0; set x137 0; set x138 0; set x139 0; + set x140 0; set x141 0; set x142 0; set x143 0; + set x144 0; set x145 0; set x146 0; set x147 0; + set x148 0; set x149 0; set x150 0; set x151 0; + set x152 0; set x153 0; set x154 0; set x155 0; + set x156 0; set x157 0; set x158 0; set x159 0; + set x160 0; set x161 0; set x162 0; set x163 0; + set x164 0; set x165 0; set x166 0; set x167 0; + set x168 0; set x169 0; set x170 0; set x171 0; + set x172 0; set x173 0; set x174 0; set x175 0; + set x176 0; set x177 0; set x178 0; set x179 0; + set x180 0; set x181 0; set x182 0; set x183 0; + set x184 0; set x185 0; set x186 0; set x187 0; + set x188 0; set x189 0; set x190 0; set x191 0; + set x192 0; set x193 0; set x194 0; set x195 0; + set x196 0; set x197 0; set x198 0; set x199 0; + set x200 0; set x201 0; set x202 0; set x203 0; + set x204 0; set x205 0; set x206 0; set x207 0; + set x208 0; set x209 0; set x210 0; set x211 0; + set x212 0; set x213 0; set x214 0; set x215 0; + set x216 0; set x217 0; set x218 0; set x219 0; + set x220 0; set x221 0; set x222 0; set x223 0; + set x224 0; set x225 0; set x226 0; set x227 0; + set x228 0; set x229 0; set x230 0; set x231 0; + set x232 0; set x233 0; set x234 0; set x235 0; + set x236 0; set x237 0; set x238 0; set x239 0; + set x240 0; set x241 0; set x242 0; set x243 0; + set x244 0; set x245 0; set x246 0; set x247 0; + set x248 0; set x249 0; set x250 0; set x251 0; set x252 0; set x253 0; set x254 0; set x255 0; set x {{1 2} {3 4}} lset x 1 1 5 @@ -338,69 +338,69 @@ test lsetComp-3.6 {lset, compiled, flat args, array, one-byte offset} { test lsetComp-3.7 {lset, compiled, flat args, array, four-byte offset} { evalInProc { - set x0 0; set x1 0; set x2 0; set x3 0; - set x4 0; set x5 0; set x6 0; set x7 0; - set x8 0; set x9 0; set x10 0; set x11 0; - set x12 0; set x13 0; set x14 0; set x15 0; - set x16 0; set x17 0; set x18 0; set x19 0; - set x20 0; set x21 0; set x22 0; set x23 0; - set x24 0; set x25 0; set x26 0; set x27 0; - set x28 0; set x29 0; set x30 0; set x31 0; - set x32 0; set x33 0; set x34 0; set x35 0; - set x36 0; set x37 0; set x38 0; set x39 0; - set x40 0; set x41 0; set x42 0; set x43 0; - set x44 0; set x45 0; set x46 0; set x47 0; - set x48 0; set x49 0; set x50 0; set x51 0; - set x52 0; set x53 0; set x54 0; set x55 0; - set x56 0; set x57 0; set x58 0; set x59 0; - set x60 0; set x61 0; set x62 0; set x63 0; - set x64 0; set x65 0; set x66 0; set x67 0; - set x68 0; set x69 0; set x70 0; set x71 0; - set x72 0; set x73 0; set x74 0; set x75 0; - set x76 0; set x77 0; set x78 0; set x79 0; - set x80 0; set x81 0; set x82 0; set x83 0; - set x84 0; set x85 0; set x86 0; set x87 0; - set x88 0; set x89 0; set x90 0; set x91 0; - set x92 0; set x93 0; set x94 0; set x95 0; - set x96 0; set x97 0; set x98 0; set x99 0; - set x100 0; set x101 0; set x102 0; set x103 0; - set x104 0; set x105 0; set x106 0; set x107 0; - set x108 0; set x109 0; set x110 0; set x111 0; - set x112 0; set x113 0; set x114 0; set x115 0; - set x116 0; set x117 0; set x118 0; set x119 0; - set x120 0; set x121 0; set x122 0; set x123 0; - set x124 0; set x125 0; set x126 0; set x127 0; - set x128 0; set x129 0; set x130 0; set x131 0; - set x132 0; set x133 0; set x134 0; set x135 0; - set x136 0; set x137 0; set x138 0; set x139 0; - set x140 0; set x141 0; set x142 0; set x143 0; - set x144 0; set x145 0; set x146 0; set x147 0; - set x148 0; set x149 0; set x150 0; set x151 0; - set x152 0; set x153 0; set x154 0; set x155 0; - set x156 0; set x157 0; set x158 0; set x159 0; - set x160 0; set x161 0; set x162 0; set x163 0; - set x164 0; set x165 0; set x166 0; set x167 0; - set x168 0; set x169 0; set x170 0; set x171 0; - set x172 0; set x173 0; set x174 0; set x175 0; - set x176 0; set x177 0; set x178 0; set x179 0; - set x180 0; set x181 0; set x182 0; set x183 0; - set x184 0; set x185 0; set x186 0; set x187 0; - set x188 0; set x189 0; set x190 0; set x191 0; - set x192 0; set x193 0; set x194 0; set x195 0; - set x196 0; set x197 0; set x198 0; set x199 0; - set x200 0; set x201 0; set x202 0; set x203 0; - set x204 0; set x205 0; set x206 0; set x207 0; - set x208 0; set x209 0; set x210 0; set x211 0; - set x212 0; set x213 0; set x214 0; set x215 0; - set x216 0; set x217 0; set x218 0; set x219 0; - set x220 0; set x221 0; set x222 0; set x223 0; - set x224 0; set x225 0; set x226 0; set x227 0; - set x228 0; set x229 0; set x230 0; set x231 0; - set x232 0; set x233 0; set x234 0; set x235 0; - set x236 0; set x237 0; set x238 0; set x239 0; - set x240 0; set x241 0; set x242 0; set x243 0; - set x244 0; set x245 0; set x246 0; set x247 0; - set x248 0; set x249 0; set x250 0; set x251 0; + set x0 0; set x1 0; set x2 0; set x3 0; + set x4 0; set x5 0; set x6 0; set x7 0; + set x8 0; set x9 0; set x10 0; set x11 0; + set x12 0; set x13 0; set x14 0; set x15 0; + set x16 0; set x17 0; set x18 0; set x19 0; + set x20 0; set x21 0; set x22 0; set x23 0; + set x24 0; set x25 0; set x26 0; set x27 0; + set x28 0; set x29 0; set x30 0; set x31 0; + set x32 0; set x33 0; set x34 0; set x35 0; + set x36 0; set x37 0; set x38 0; set x39 0; + set x40 0; set x41 0; set x42 0; set x43 0; + set x44 0; set x45 0; set x46 0; set x47 0; + set x48 0; set x49 0; set x50 0; set x51 0; + set x52 0; set x53 0; set x54 0; set x55 0; + set x56 0; set x57 0; set x58 0; set x59 0; + set x60 0; set x61 0; set x62 0; set x63 0; + set x64 0; set x65 0; set x66 0; set x67 0; + set x68 0; set x69 0; set x70 0; set x71 0; + set x72 0; set x73 0; set x74 0; set x75 0; + set x76 0; set x77 0; set x78 0; set x79 0; + set x80 0; set x81 0; set x82 0; set x83 0; + set x84 0; set x85 0; set x86 0; set x87 0; + set x88 0; set x89 0; set x90 0; set x91 0; + set x92 0; set x93 0; set x94 0; set x95 0; + set x96 0; set x97 0; set x98 0; set x99 0; + set x100 0; set x101 0; set x102 0; set x103 0; + set x104 0; set x105 0; set x106 0; set x107 0; + set x108 0; set x109 0; set x110 0; set x111 0; + set x112 0; set x113 0; set x114 0; set x115 0; + set x116 0; set x117 0; set x118 0; set x119 0; + set x120 0; set x121 0; set x122 0; set x123 0; + set x124 0; set x125 0; set x126 0; set x127 0; + set x128 0; set x129 0; set x130 0; set x131 0; + set x132 0; set x133 0; set x134 0; set x135 0; + set x136 0; set x137 0; set x138 0; set x139 0; + set x140 0; set x141 0; set x142 0; set x143 0; + set x144 0; set x145 0; set x146 0; set x147 0; + set x148 0; set x149 0; set x150 0; set x151 0; + set x152 0; set x153 0; set x154 0; set x155 0; + set x156 0; set x157 0; set x158 0; set x159 0; + set x160 0; set x161 0; set x162 0; set x163 0; + set x164 0; set x165 0; set x166 0; set x167 0; + set x168 0; set x169 0; set x170 0; set x171 0; + set x172 0; set x173 0; set x174 0; set x175 0; + set x176 0; set x177 0; set x178 0; set x179 0; + set x180 0; set x181 0; set x182 0; set x183 0; + set x184 0; set x185 0; set x186 0; set x187 0; + set x188 0; set x189 0; set x190 0; set x191 0; + set x192 0; set x193 0; set x194 0; set x195 0; + set x196 0; set x197 0; set x198 0; set x199 0; + set x200 0; set x201 0; set x202 0; set x203 0; + set x204 0; set x205 0; set x206 0; set x207 0; + set x208 0; set x209 0; set x210 0; set x211 0; + set x212 0; set x213 0; set x214 0; set x215 0; + set x216 0; set x217 0; set x218 0; set x219 0; + set x220 0; set x221 0; set x222 0; set x223 0; + set x224 0; set x225 0; set x226 0; set x227 0; + set x228 0; set x229 0; set x230 0; set x231 0; + set x232 0; set x233 0; set x234 0; set x235 0; + set x236 0; set x237 0; set x238 0; set x239 0; + set x240 0; set x241 0; set x242 0; set x243 0; + set x244 0; set x245 0; set x246 0; set x247 0; + set x248 0; set x249 0; set x250 0; set x251 0; set x252 0; set x253 0; set x254 0; set x255 0; set y(0) {{1 2} {3 4}} lset y(0) 1 1 5 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 351fd4f..5b43b43 100644 --- a/tests/main.test +++ b/tests/main.test @@ -16,7 +16,7 @@ namespace eval ::tcl::test::main { # - tests use testing commands introduced in Tcltest 8.4 testConstraint Tcltest [expr { [llength [package provide Tcltest]] - && [package vsatisfies [package provide Tcltest] 8.4]}] + && [package vsatisfies [package provide Tcltest] 8.5-]}] # Procedure to simulate interactive typing of commands, line by line proc type {chan script} { @@ -719,7 +719,7 @@ namespace eval ::tcl::test::main { } -result "Exit MainLoop\nIn exit\neven 0\n" test Tcl_Main-5.9 { - Tcl_Main: interactive mode: delete interp + Tcl_Main: interactive mode: delete interp -> main loop & exit handlers, but no [exit] } -constraints { exec Tcltest @@ -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/misc.test b/tests/misc.test index d4ece74..db8b14a 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -25,7 +25,7 @@ testConstraint testhashsystemhash [llength [info commands testhashsystemhash]] test misc-1.1 {error in variable ref. in command in array reference} { proc tstProc {} { global a - + set tst $a([winfo name $zz]) # this is a bogus comment # this is a bogus comment @@ -42,7 +42,7 @@ test misc-1.1 {error in variable ref. in command in array reference} { test misc-1.2 {error in variable ref. in command in array reference} { proc tstProc {} " global a - + set tst \$a(\[winfo name \$\{zz) # this is a bogus comment # this is a bogus comment diff --git a/tests/msgcat.test b/tests/msgcat.test index 1c3ce58..3dde124 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -55,8 +55,13 @@ namespace eval ::msgcat::test { set result [string tolower [lindex $setVars 0]] if {[string length $result] == 0} { if {[info exists ::tcl::mac::locale]} { +if {[package vsatisfies [package provide msgcat] 1.7]} { + set result [string tolower \ + [msgcat::mcutil::ConvertLocale $::tcl::mac::locale]] +} else { set result [string tolower \ [msgcat::ConvertLocale $::tcl::mac::locale]] +} } else { if {([info sharedlibextension] eq ".dll") && ![catch {package require registry}]} { @@ -194,6 +199,28 @@ namespace eval ::msgcat::test { mclocale looks/ok/../../../../but/is/path/to/evil/code } -returnCodes error -match glob -result {invalid newLocale value *} + test msgcat-1.14 {mcpreferences, custom locale preferences} -setup { + variable locale [mclocale] + mclocale en + mcpreferences fr en {} + } -cleanup { + mclocale $locale + } -body { + mcpreferences + } -result {fr en {}} + + test msgcat-1.15 {mcpreferences, overwrite custom locale preferences}\ + -setup { + variable locale [mclocale] + mcpreferences fr en {} + mclocale en + } -cleanup { + mclocale $locale + } -body { + mcpreferences + } -result {en {}} + + # Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning test msgcat-2.1 {mcset, global scope} { @@ -688,7 +715,7 @@ namespace eval ::msgcat::test { test msgcat-9.1 {mcexists no parameter} -body { mcexists } -returnCodes 1\ - -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? src"} + -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? ?-namespace ns? src"} test msgcat-9.2 {mcexists unknown option} -body { mcexists -unknown src @@ -724,12 +751,34 @@ namespace eval ::msgcat::test { mcset foo k1 v1 } -cleanup { mclocale $locale + namespace delete ::foo } -body { - namespace eval ::msgcat::test::sub { + namespace eval ::foo { list [::msgcat::mcexists k1]\ - [::msgcat::mcexists -exactnamespace k1] + [::msgcat::mcexists -namespace ::msgcat::test k1] } - } -result {1 0} + } -result {0 1} + + test msgcat-9.6 {mcexists -namespace ns parameter} -setup { + mcforgetpackage + variable locale [mclocale] + mclocale foo_bar + mcset foo k1 v1 + } -cleanup { + mclocale $locale + namespace delete ::foo + } -body { + namespace eval ::foo { + list [::msgcat::mcexists k1]\ + [::msgcat::mcexists -namespace ::msgcat::test k1] + } + } -result {0 1} + + test msgcat-9.7 {mcexists -namespace - ns argument missing} -body { + mcexists -namespace src + } -returnCodes 1\ + -result {Argument missing for switch "-namespace"} + # Tests msgcat-10.*: [mcloadedlocales] @@ -811,13 +860,18 @@ namespace eval ::msgcat::test { test msgcat-12.1 {mcpackagelocale no subcommand} -body { mcpackagelocale } -returnCodes 1\ - -result {wrong # args: should be "mcpackagelocale subcommand ?locale?"} + -result {wrong # args: should be "mcpackagelocale subcommand ?arg ...?"} test msgcat-12.2 {mclpackagelocale wrong subcommand} -body { mcpackagelocale junk } -returnCodes 1\ -result {unknown subcommand "junk": must be clear, get, isset, loaded, present, set, or unset} + test msgcat-12.2.1 {mclpackagelocale set multiple args} -body { + mcpackagelocale set a b + } -returnCodes 1\ + -result {wrong # args: should be "mcpackagelocale set ?locale?"} + test msgcat-12.3 {mcpackagelocale set} -setup { variable locale [mclocale] } -cleanup { @@ -922,6 +976,30 @@ namespace eval ::msgcat::test { list [mcpackagelocale present foo] [mcpackagelocale present bar] } -result {0 1} + test msgcat-12.11 {mcpackagelocale custom preferences} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mclocale foo + set res [list [mcpackagelocale preferences]] + mcpackagelocale preferences bar {} + lappend res [mcpackagelocale preferences] + } -result {{foo {}} {bar {}}} + + test msgcat-12.12 {mcpackagelocale preferences -> no isset} -setup { + variable locale [mclocale] + } -cleanup { + mclocale $locale + mcforgetpackage + } -body { + mclocale foo + mcpackagelocale preferences + mcpackagelocale isset + } -result {0} + + # Tests msgcat-13.*: [mcpackageconfig subcmds] test msgcat-13.1 {mcpackageconfig no subcommand} -body { @@ -1073,8 +1151,212 @@ namespace eval ::msgcat::test { } -returnCodes 1\ -result {fail} + + # 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 + + test msgcat-15.1 {mc in class setup} -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::class create ClassCur + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace delete bar + } -body { + oo::define bar::ClassCur msgcat::mc con2 + } -result con2bar + + test msgcat-15.2 {mc in class} -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::class create ClassCur + oo::define ClassCur method method1 {} {::msgcat::mc con2} + } + # full namespace is ::msgcat::test:baz + namespace eval baz { + set ObjCur [::msgcat::test::bar::ClassCur new] + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace delete bar baz + } -body { + $baz::ObjCur method1 + } -result con2bar + + test msgcat-15.3 {mc in classless object} -setup { + # full namespace is ::msgcat::test:bar + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} {::msgcat::mc con2} + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace delete bar + } -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 + namespace eval bar { + ::msgcat::mcset foo_BAR con2 con2bar + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} { + namespace eval ::msgcat::test::baz { + ::msgcat::mc con2 + } + } + } + namespace eval baz { + ::msgcat::mcset foo_BAR con2 con2baz + } + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + namespace eval bar {::msgcat::mcforgetpackage} + namespace eval baz {::msgcat::mcforgetpackage} + namespace delete bar baz + } -body { + bar::ObjCur method1 + } -result con2baz + + # Test msgcat-16.*: command mcpackagenamespaceget + + test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body { + namespace eval baz {msgcat::mcpackagenamespaceget} + } -result ::msgcat::test::baz + + test msgcat-16.2 {mcpackagenamespaceget in class setup} -setup { + namespace eval bar { + oo::class create ClassCur + oo::define ClassCur variable a + } + } -cleanup { + namespace delete bar + } -body { + oo::define bar::ClassCur msgcat::mcpackagenamespaceget + } -result ::msgcat::test::bar + + test msgcat-16.3 {mcpackagenamespaceget in class} -setup { + namespace eval bar { + oo::class create ClassCur + oo::define ClassCur method method1 {} {msgcat::mcpackagenamespaceget} + } + namespace eval baz { + set ObjCur [::msgcat::test::bar::ClassCur new] + } + } -cleanup { + namespace delete bar baz + } -body { + $baz::ObjCur method1 + } -result ::msgcat::test::bar + + test msgcat-16.4 {mcpackagenamespaceget in classless object} -setup { + namespace eval bar { + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} {msgcat::mcpackagenamespaceget} + } + } -cleanup { + namespace delete bar + } -body { + bar::ObjCur method1 + } -result ::msgcat::test::bar + + test msgcat-16.5\ + {mcpackagenamespaceget in classless object with explicite namespace eval}\ + -setup { + namespace eval bar { + oo::object create ObjCur + oo::objdefine ObjCur method method1 {} { + namespace eval ::msgcat::test::baz { + msgcat::mcpackagenamespaceget + } + } + } + } -cleanup { + namespace delete bar baz + } -body { + bar::ObjCur method1 + } -result ::msgcat::test::baz + + + # Test msgcat-17.*: mcn command + + test msgcat-17.1 {mcn no parameters} -body { + mcn + } -returnCodes 1\ + -result {wrong # args: should be "mcn ns src ?arg ...?"} + + test msgcat-17.2 {mcn} -setup { + namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar} + variable locale [mclocale] + mclocale foo_BAR + } -cleanup { + mclocale $locale + } -body { + ::msgcat::mcn [namespace current]::bar con1 + } -result con1bar + + interp bgerror {} $bgerrorsaved + # Tests msgcat-18.*: [mcutil] + + test msgcat-18.1 {mcutil - no argument} -body { + mcutil + } -returnCodes 1\ + -result {wrong # args: should be "mcutil subcommand ?arg ...?"} + + test msgcat-18.2 {mcutil - wrong argument} -body { + 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 + test msgcat-18.7 {mcutil getsystemlocale} -body { + mcutil getsystemlocale + set ok ok + } -result {ok} + + cleanupTests } namespace delete ::msgcat::test diff --git a/tests/namespace.test b/tests/namespace.test index f2d7061..606139f 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -56,7 +56,7 @@ test namespace-2.2 {Tcl_GetCurrentNamespace} { test namespace-3.1 {Tcl_GetGlobalNamespace} { namespace eval test_ns_1 {namespace eval foo {namespace eval bar {} } } - # namespace children uses Tcl_GetGlobalNamespace + # namespace children uses Tcl_GetGlobalNamespace namespace eval test_ns_1 {namespace children foo b*} } {::test_ns_1::foo::bar} @@ -108,7 +108,7 @@ test namespace-6.2 {Tcl_CreateNamespace, odd number of :'s in name is okay} { [namespace eval test_ns_2:::::foo {namespace current}] } {::test_ns_1::foo ::test_ns_2::foo} test namespace-6.3 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} { - list [catch {namespace eval test_ns_7::: {namespace current}} msg] $msg + list [catch {namespace eval test_ns_7::: {namespace current}} msg] $msg } {0 ::test_ns_7} test namespace-6.4 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -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 {} @@ -278,7 +278,7 @@ test namespace-8.5 {TclTeardownNamespace: preserve errorInfo; errorCode values} invoked from within "slave eval error foo bar baz"} test namespace-8.6 {TclTeardownNamespace: preserve errorInfo; errorCode values} { - interp create slave + interp create slave slave eval {trace add variable errorCode write {namespace delete :: ;#}} catch {slave eval error foo bar baz} interp delete slave @@ -1098,17 +1098,17 @@ test namespace-22.5 {NamespaceCodeCmd, in other namespace} { namespace code cmd } } {::namespace inscope ::test_ns_1 cmd} -test namespace-22.6 {NamespaceCodeCmd, in other namespace} { - namespace eval test_ns_1 { - variable v 42 - } - namespace eval test_ns_2 { - proc namespace args {} - } - namespace eval test_ns_2 [namespace eval test_ns_1 { - namespace code {set v} - }] -} {42} +test namespace-22.6 {NamespaceCodeCmd, in other namespace} { + namespace eval test_ns_1 { + variable v 42 + } + namespace eval test_ns_2 { + proc namespace args {} + } + namespace eval test_ns_2 [namespace eval test_ns_1 { + namespace code {set v} + }] +} {42} test namespace-22.7 {NamespaceCodeCmd, Bug 3202171} { namespace eval demo { proc namespace args {puts $args} @@ -1659,7 +1659,7 @@ test namespace-40.1 {Ignoring namespace proc "unknown"} -setup { namespace eval ns {proc unknown args {return local}} list [namespace eval ns aaa bbb] [namespace eval ns aaa] } -cleanup { - rename unknown {} + rename unknown {} rename _unknown unknown namespace delete ns } -result {global global} @@ -1670,7 +1670,7 @@ test namespace-41.1 {Shadowing byte-compiled commands, Bug: 231259} { set res {} proc test {} { set ::g 0 - } + } lappend ::res [test] proc set {a b} { ::set a [incr b] @@ -1797,7 +1797,7 @@ test namespace-42.7 {ensembles: nested} -body { list [ns x0 z] [ns x1] [ns x2] [ns x3] } -cleanup { namespace delete ns -} -result {{1 ::ns::x0::z} 1 2 3} +} -result {{1 z} 1 2 3} test namespace-42.8 { ensembles: [Bug 1670091], panic due to pointer to a deallocated List struct. @@ -1964,7 +1964,7 @@ test namespace-44.5 {ensemble: errors} -setup { foobar foobarcon } -cleanup { rename foobar {} -} -returnCodes error -result {invalid command name "::foobarconfigure"} +} -returnCodes error -result {invalid command name "foobarconfigure"} test namespace-44.6 {ensemble: errors} -returnCodes error -body { namespace ensemble create gorp } -result {wrong # args: should be "namespace ensemble create ?option value ...?"} @@ -2128,7 +2128,7 @@ test namespace-47.1 {ensemble: unknown handler} { lappend result [catch {ns c d e} msg] $msg lappend result [catch {ns Magic foo bar spong wibble} msg] $msg list $result [lsort [info commands ::ns::*]] $log [namespace delete ns] -} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running ::ns::a b c} {running ::ns::a b c} {making b} {running ::ns::b c d} {making c} {running ::ns::c d e} {unknown Magic - args = foo bar spong wibble}} {}} +} {{0 2 0 2 0 2 0 2 1 {unknown or protected subcommand "Magic"}} {::ns::Magic ::ns::a ::ns::b ::ns::c} {{making a} {running a b c} {running a b c} {making b} {running b c d} {making c} {running c d e} {unknown Magic - args = foo bar spong wibble}} {}} test namespace-47.2 {ensemble: unknown handler} { namespace eval ns { namespace export {[a-z]*} @@ -3227,7 +3227,7 @@ test namespace-53.10 {ensembles: nested rewrite} -setup { 1 {wrong # args: should be "ns z1 x a1"}\ 1 {wrong # args: should be "ns z2 x a1 a2"}\ 1 {wrong # args: should be "ns z2 x a1 a2"}\ - 1 {wrong # args: should be "::ns::x::z0"}\ + 1 {wrong # args: should be "z0"}\ 0 {1 v}\ 1 {wrong # args: should be "ns v x z2 a2"}\ 0 {2 v v2}} @@ -3311,6 +3311,18 @@ test namespace-56.3 {bug f97d4ee020: mutually-entangled deletion} { } } } {::testing::abc::def ::testing::abc::ghi} + +test namespace-56.4 {bug 16fe1b5807: names starting with ":"} { +namespace eval : { + namespace ensemble create + namespace export * + proc p1 {} { + return 16fe1b5807 + } +} + +: p1 +} 16fe1b5807 # cleanup catch {rename cmd1 {}} diff --git a/tests/notify.test b/tests/notify.test index d2b9123..d2b9123 100644..100755 --- a/tests/notify.test +++ b/tests/notify.test diff --git a/tests/nre.test b/tests/nre.test index 09061d2..58f5511 100644 --- a/tests/nre.test +++ b/tests/nre.test @@ -29,9 +29,9 @@ if {[testConstraint testnrelevels]} { namespace path ::tcl::mathop # # [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels, - # cmdFrame level, callFrame level, tosPtr and callback depth + # cmdFrame level, callFrame level, tosPtr and callback depth # - variable last [testnrelevels] + variable last [testnrelevels] proc depthDiff {} { variable last set depth [testnrelevels] @@ -329,7 +329,7 @@ test nre-8.1 {nre and {*}} -body { } -cleanup { rename inner {} rename outer {} -} -result {1 1 1} +} -result {1 1 1} test nre-8.2 {nre and {*}, [Bug 2415422]} -body { # force an expansion that grows the evaluation stack, check that nre # adapts the bcFramePtr. This causes an NRE assertion to fail if it is not diff --git a/tests/obj.test b/tests/obj.test index 7273b40..87c8d08 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -20,18 +20,16 @@ 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 foreach {t} { - {array search} bytearray bytecode cmdName dict - end-offset regexp string } { @@ -53,15 +51,6 @@ test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} testobj { lappend result [testobj refcount 1] } {{} 12 12 bytearray 3} -test obj-3.1 {Tcl_ConvertToType error} testobj { - list [testdoubleobj set 1 12.34] \ - [catch {testobj convert 1 end-offset} msg] \ - $msg -} {12.34 1 {bad index "12.34": must be end?[+-]integer?}} -test obj-3.2 {Tcl_ConvertToType error, "empty string" object} testobj { - list [testobj newobj 1] [catch {testobj convert 1 end-offset} msg] $msg -} {{} 1 {bad index "": must be end?[+-]integer?}} - test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj { set result "" lappend result [testobj freeallvars] @@ -82,7 +71,7 @@ test obj-6.1 {Tcl_DuplicateObj, object has internal rep} testobj { set result "" lappend result [testobj freeallvars] lappend result [testintobj set 1 47] - lappend result [testobj duplicate 1 2] + lappend result [testobj duplicate 1 2] lappend result [testintobj get 2] lappend result [testobj refcount 1] lappend result [testobj refcount 2] @@ -91,7 +80,7 @@ test obj-6.2 {Tcl_DuplicateObj, "empty string" object} testobj { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] - lappend result [testobj duplicate 1 2] + lappend result [testobj duplicate 1 2] lappend result [testintobj get 2] lappend result [testobj refcount 1] lappend result [testobj refcount 2] @@ -551,44 +540,6 @@ test obj-30.1 {Ref counting and object deletion, simple types} testobj { lappend result [testobj refcount 2] } {{} 1024 1024 int 4 4 0 int 3 2} - -test obj-31.1 {regenerate string rep of "end"} testobj { - testobj freeallvars - teststringobj set 1 end - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end -test obj-31.2 {regenerate string rep of "end-1"} testobj { - testobj freeallvars - teststringobj set 1 end-0x1 - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end-1 -test obj-31.3 {regenerate string rep of "end--1"} testobj { - testobj freeallvars - teststringobj set 1 end--0x1 - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end--1 -test obj-31.4 {regenerate string rep of "end-bigInteger"} testobj { - testobj freeallvars - teststringobj set 1 end-0x7fffffff - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end-2147483647 -test obj-31.5 {regenerate string rep of "end--bigInteger"} testobj { - testobj freeallvars - teststringobj set 1 end--0x7fffffff - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end--2147483647 -test obj-31.6 {regenerate string rep of "end--bigInteger"} {testobj longIs32bit} { - testobj freeallvars - teststringobj set 1 end--0x80000000 - testobj convert 1 end-offset - testobj invalidateStringRep 1 -} end--2147483648 - test obj-32.1 {freeing very large object trees} { set x {} for {set i 0} {$i<100000} {incr i} { @@ -597,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 8850ea5..37c4495 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -13,6 +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 {} { @@ -47,7 +52,7 @@ test oo-0.2 {basic test of OO's ability to clean up its initial state} { } {} test oo-0.3 {basic test of OO's ability to clean up its initial state} -body { leaktest { - [oo::object new] destroy + [oo::object new] destroy } } -constraints memory -result 0 test oo-0.4 {basic test of OO's ability to clean up its initial state} -body { @@ -57,7 +62,13 @@ test oo-0.4 {basic test of OO's ability to clean up its initial state} -body { foo destroy } } -constraints memory -result 0 -test oo-0.5 {testing literal leak on interp delete} memory { +test oo-0.5.1 {testing object foundation cleanup} memory { + leaktest { + interp create foo + interp delete foo + } +} 0 +test oo-0.5.2 {testing literal leak on interp delete} memory { leaktest { interp create foo foo eval {oo::object new} @@ -128,6 +139,13 @@ test oo-1.3 {basic test of OO functionality: no classes} { test oo-1.4 {basic test of OO functionality} -body { oo::object create {} } -returnCodes 1 -result {object name must not be empty} +test oo-1.4.1 {fully-qualified nested name} -body { + oo::object create ::one::two::three +} -result {::one::two::three} +test oo-1.4.2 {automatic command name has same name as namespace} -body { + set obj [oo::object new] + expr {[info object namespace $obj] == $obj} +} -result 1 test oo-1.5 {basic test of OO functionality} -body { oo::object doesnotexist } -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new} @@ -258,7 +276,21 @@ test oo-1.18 {OO: create object in NS with same name as global cmd} -setup { rename test-oo-1.18 {} A destroy } -result ::C -test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup { +test oo-1.18.1 {no memory leak: superclass} -setup { +} -constraints memory -body { + + leaktest { + interp create t + t eval { + oo::class create A { + superclass oo::class + } + } + interp delete t + } +} -cleanup { +} -result 0 +test oo-1.18.2 {Bug 75b8433707: memory leak in oo-1.18} -setup { proc test-oo-1.18 {} return } -constraints memory -body { leaktest { @@ -271,7 +303,7 @@ test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup { } -cleanup { rename test-oo-1.18 {} } -result 0 -test oo-1.18.2 {Bug 21c144f0f5} -setup { +test oo-1.18.3 {Bug 21c144f0f5} -setup { interp create slave } -body { slave eval { @@ -280,7 +312,7 @@ test oo-1.18.2 {Bug 21c144f0f5} -setup { } } -cleanup { interp delete slave -} +} test oo-1.19 {basic test of OO functionality: teardown order} -body { oo::object create o namespace delete [info object namespace o] @@ -306,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 @@ -1482,6 +1514,87 @@ test oo-11.4 {OO: cleanup} { lappend result [bar0 destroy] [oo::object create foo] [foo destroy] \ [oo::object create bar2] [bar2 destroy] } {1 {can't create object "foo": command already exists with that name} destroyed {} ::foo {} ::bar2 {}} +test oo-11.5 {OO: cleanup} { + oo::class create obj1 + + trace add command obj1 delete {apply {{name1 name2 action} { + set namespace [info object namespace $name1] + namespace delete $namespace + }}} + + rename obj1 {} + # No segmentation fault + return done +} done + +test oo-11.6.1 { + OO: cleanup of when an class is mixed into itself +} -constraints memory -body { + leaktest { + interp create interp1 + oo::class create obj1 + ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]} + rename obj1 {} + interp delete interp1 + } +} -result 0 -cleanup { +} + +test oo-11.6.2 { + OO: cleanup ReleaseClassContents() where class is mixed into one of its + instances +} -constraints memory -body { + leaktest { + interp create interp1 + interp1 eval { + oo::class create obj1 + ::oo::copy obj1 obj2 + rename obj2 {} + rename obj1 {} + } + interp delete interp1 + } +} -result 0 -cleanup { +} + +test oo-11.6.3 { + OO: cleanup ReleaseClassContents() where class is mixed into one of its + instances +} -constraints memory -body { + leaktest { + interp create interp1 + interp1 eval { + oo::class create obj1 + ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]} + + ::oo::copy obj1 obj2 + rename obj2 {} + rename obj1 {} + } + interp delete interp1 + } +} -result 0 -cleanup { +} + +test oo-11.6.4 { + OO: cleanup ReleaseClassContents() where class is mixed into one of its + instances +} -body { + oo::class create obj1 + ::oo::define obj1 {self mixin [self]} + + ::oo::copy obj1 obj2 + ::oo::objdefine obj2 {mixin [self]} + + ::oo::copy obj2 obj3 + rename obj3 {} + rename obj2 {} + + # No segmentation fault + return done +} -result done -cleanup { + rename obj1 {} +} test oo-12.1 {OO: filters} { oo::class create Aclass @@ -1689,6 +1802,106 @@ test oo-13.4 {OO: changing an object's class} -body { foo destroy bar destroy } -result {::foo ::foo ::foo ::bar} +test oo-13.5 {OO: changing an object's class: non-class to class} -setup { + oo::object create fooObj +} -body { + oo::objdefine fooObj { + class oo::class + } + oo::define fooObj { + method x {} {expr 1+2+3} + } + [fooObj new] x +} -cleanup { + fooObj destroy +} -result 6 +test oo-13.6 {OO: changing an object's class: class to non-class} -setup { + oo::class create foo + unset -nocomplain ::result +} -body { + set result dangling + oo::define foo { + method x {} {expr 1+2+3} + } + oo::class create boo { + superclass foo + destructor {set ::result "ok"} + } + boo new + foo create bar + oo::objdefine foo { + class oo::object + } + list $result [catch {bar x} msg] $msg +} -cleanup { + catch {bar destroy} + foo destroy +} -result {ok 1 {invalid command name "bar"}} +test oo-13.7 {OO: changing an object's class} -setup { + oo::class create foo + oo::class create bar + unset -nocomplain result +} -body { + oo::define bar method x {} {return ok} + oo::define foo { + method x {} {expr 1+2+3} + self mixin foo + } + lappend result [foo x] + oo::objdefine foo class bar + lappend result [foo x] +} -cleanup { + foo destroy + bar destroy +} -result {6 ok} +test oo-13.8 {OO: changing an object's class to itself} -setup { + oo::class create foo +} -body { + oo::define foo { + method x {} {expr 1+2+3} + } + oo::objdefine foo class foo +} -cleanup { + foo destroy +} -returnCodes error -result {may not change classes into an instance of themselves} +test oo-13.9 {OO: changing an object's class: roots are special} -setup { + set i [interp create] +} -body { + $i eval { + oo::objdefine oo::object { + class oo::class + } + } +} -cleanup { + interp delete $i +} -returnCodes error -result {may not modify the class of the root object class} +test oo-13.10 {OO: changing an object's class: roots are special} -setup { + set i [interp create] +} -body { + $i eval { + oo::objdefine oo::class { + class oo::object + } + } +} -cleanup { + interp delete $i +} -returnCodes error -result {may not modify the class of the class of classes} +test oo-13.11 {OO: changing an object's class in a tricky place} -setup { + oo::class create cls + unset -nocomplain result +} -body { + set result gorp + list [catch { + oo::define cls { + method x {} {return} + self class oo::object + ::set ::result ok + method y {} {return}; # I'm sorry, Dave. I'm afraid I can't do that. + } + } msg] $msg $result +} -cleanup { + cls destroy +} -result {1 {attempt to misuse API} ok} # todo: changing a class subtype (metaclass) to another class subtype test oo-14.1 {OO: mixins} { @@ -1989,7 +2202,7 @@ test oo-15.10 {variable binding must not bleed through oo::copy} -setup { } -body { set obj1 [FooClass new] oo::objdefine $obj1 { - variable var + variable var method m {} { set var foo } @@ -2026,7 +2239,20 @@ test oo-15.12 {OO: object cloning with target NS} -setup { Super destroy catch {namespace delete ::existing} } -result {::existing refers to an existing namespace} -test oo-15.13 {OO: object cloning with target NS} -setup { +test oo-15.13.1 { + OO: object cloning with target NS + Valgrind will report a leak if the reference count of the namespace isn't + properly incremented. +} -setup { + oo::class create Cls {} +} -body { + oo::copy Cls Cls2 ::dupens + return done +} -cleanup { + Cls destroy + Cls2 destroy +} -result done +test oo-15.13.2 {OO: object cloning with target NS} -setup { oo::class create Super oo::class create Cls {superclass Super} } -body { @@ -2053,7 +2279,7 @@ test oo-15.15 {method cloning must ensure that there is a string representation } -body { cls create foo oo::objdefine foo { - method m1 {} [string map {a b} {return hello}] + method m1 {} [string map {a b} {return hello}] } [oo::copy foo] m1 } -cleanup { @@ -2074,7 +2300,7 @@ test oo-16.2 {OO: object introspection} -body { } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} test oo-16.3 {OO: object introspection} -body { info object gorp oo::object -} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars} +} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars} test oo-16.4 {OO: object introspection} -setup { oo::class create meta { superclass oo::class } [meta create instance1] create instance2 @@ -2204,6 +2430,73 @@ test oo-16.14 {OO: object introspection: TIP #436} -setup { } -cleanup { meta destroy } -result {class {0 0} meta {0 0 0} type {0 0 0 0 0 0} mix {0 0 0 0 0 0}} +test oo-16.15 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + info object creationid [cls new] +} -cleanup { + cls destroy +} -result {^\d+$} -match regexp +test oo-16.16 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + set obj [cls new] + set id [info object creationid $obj] + rename $obj gorp + set id2 [info object creationid gorp] + list $id $id2 +} -cleanup { + cls destroy +} -result {^(\d+) \1$} -match regexp +test oo-16.17 {OO: object introspection: creationid #500} -body { + info object creationid nosuchobject +} -returnCodes error -result {nosuchobject does not refer to an object} +test oo-16.18 {OO: object introspection: creationid #500} -body { + info object creationid +} -returnCodes error -result {wrong # args: should be "info object creationid objName"} +test oo-16.18 {OO: object introspection: creationid #500} -body { + info object creationid oo::object gorp +} -returnCodes error -result {wrong # args: should be "info object creationid objName"} +test oo-16.19 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + set id1 [info object creationid [set o1 [cls new]]] + set id2 [info object creationid [set o2 [cls new]]] + if {$id1 == $id2} { + format "objects %s and %s have same creation id: %d" $o1 $o2 $id1 + } else { + string cat not-equal + } +} -cleanup { + cls destroy +} -result not-equal +test oo-16.20 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + set id1 [info object creationid [set o1 [cls new]]] + $o1 destroy + set id2 [info object creationid [set o2 [cls new]]] + if {$id1 == $id2} { + format "objects %s and %s have same creation id: %d" $o1 $o2 $id1 + } else { + string cat not-equal + } +} -cleanup { + cls destroy +} -result not-equal +test oo-16.21 {OO: object introspection: creationid #500} -setup { + oo::class create cls +} -body { + set id1 [info object creationid [set o1 [cls new]]] + set id2 [info object creationid [set o2 [oo::copy $o1]]] + if {$id1 == $id2} { + format "objects %s and %s have same creation id: %d" $o1 $o2 $id1 + } else { + string cat not-equal + } +} -cleanup { + cls destroy +} -result not-equal test oo-17.1 {OO: class introspection} -body { info class @@ -2325,6 +2618,7 @@ test oo-17.14 {OO: instance method unexport (bug 900cb0284bc)} -setup { c destroy } -result $stdmethods + test oo-18.1 {OO: define command support} { list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo } {1 foo {foo @@ -2714,7 +3008,7 @@ test oo-20.10 {OO: variable and varname methods refer to same things} -setup { test oo-20.11 {OO: variable mustn't crash when recursing} -body { oo::class create A { constructor {name} { - my variable np_name + my variable np_name set np_name $name } method copy {nm} { @@ -2729,7 +3023,7 @@ test oo-20.11 {OO: variable mustn't crash when recursing} -body { lappend objs [$ref copy {}] } $cpy prop $var $objs - } else { + } else { $cpy prop $var $val } } @@ -3621,99 +3915,131 @@ test oo-31.2 {Bug 3111059: when objects and coroutines entangle} -setup { cls destroy } -result {0 {}} -oo::class create SampleSlot { - superclass oo::Slot - constructor {} { - variable contents {a b c} ops {} - } - method contents {} {variable contents; return $contents} - method ops {} {variable ops; return $ops} - method Get {} { - variable contents - variable ops - lappend ops [info level] Get - return $contents - } - method Set {lst} { - variable contents $lst - variable ops - lappend ops [info level] Set $lst - return +proc SampleSlotSetup script { + set script0 { + oo::class create SampleSlot { + superclass oo::Slot + constructor {} { + variable contents {a b c} ops {} + } + method contents {} {variable contents; return $contents} + method ops {} {variable ops; return $ops} + method Get {} { + variable contents + variable ops + lappend ops [info level] Get + return $contents + } + method Set {lst} { + variable contents $lst + variable ops + lappend ops [info level] Set $lst + return + } + method Resolve {lst} { + variable ops + lappend ops [info level] Resolve $lst + return $lst + } + } + } + append script0 \n$script +} + +proc SampleSlotCleanup script { + set script0 { + SampleSlot destroy } + append script \n$script0 } -test oo-32.1 {TIP 380: slots - class test} -setup { +test oo-32.1 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot -} -body { +}] -body { list [info level] [sampleSlot contents] [sampleSlot ops] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename sampleSlot {} -} -result {0 {a b c} {}} -test oo-32.2 {TIP 380: slots - class test} -setup { +}] -result {0 {a b c} {}} +test oo-32.2 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot -} -body { +}] -body { list [info level] [sampleSlot -clear] \ [sampleSlot contents] [sampleSlot ops] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename sampleSlot {} -} -result {0 {} {} {1 Set {}}} -test oo-32.3 {TIP 380: slots - class test} -setup { +}] -result {0 {} {} {1 Set {}}} +test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot -} -body { +}] -body { list [info level] [sampleSlot -append g h i] \ [sampleSlot contents] [sampleSlot ops] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename sampleSlot {} -} -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}} -test oo-32.4 {TIP 380: slots - class test} -setup { +}] -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 { +}] -body { list [info level] [sampleSlot -set d e f] \ [sampleSlot contents] [sampleSlot ops] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename sampleSlot {} -} -result {0 {} {d e f} {1 Set {d e f}}} -test oo-32.5 {TIP 380: slots - class test} -setup { +}] -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 { +}] -body { list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \ [sampleSlot contents] [sampleSlot ops] -} -cleanup { +} -cleanup [SampleSlotCleanup { + rename sampleSlot {} +}] -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 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}} +}] -result {0 {} b {1 Resolve c 1 Resolve a 1 Get 1 Set b}} -test oo-33.1 {TIP 380: slots - defaulting} -setup { +test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] -} -body { +}] -body { list [$s x y] [$s contents] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename $s {} -} -result {{} {a b c x y}} -test oo-33.2 {TIP 380: slots - defaulting} -setup { +}] -result {{} {a b c x y}} +test oo-33.2 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] -} -body { +}] -body { list [$s destroy; $s unknown] [$s contents] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename $s {} -} -result {{} {a b c destroy unknown}} -test oo-33.3 {TIP 380: slots - defaulting} -setup { +}] -result {{} {a b c destroy unknown}} +test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] -} -body { +}] -body { oo::objdefine $s forward --default-operation my -set list [$s destroy; $s unknown] [$s contents] [$s ops] -} -cleanup { +} -cleanup [SampleSlotCleanup { rename $s {} -} -result {{} unknown {1 Set destroy 1 Set unknown}} -test oo-33.4 {TIP 380: slots - errors} -setup { +}] -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 { +}] -body { # Method names beginning with "-" are special to slots $s -grill q -} -returnCodes error -cleanup { +} -returnCodes error -cleanup [SampleSlotCleanup { rename $s {} -} -result {unknown method "-grill": must be -append, -clear, -set, contents or ops} - -SampleSlot destroy +}] -result \ + {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] @@ -3743,25 +4069,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 { @@ -3833,6 +4202,880 @@ test oo-35.5 {Bug 1a56550e96: introspectors must traverse mixin links correctly} } -cleanup { base destroy } -result {{c d e} {c d e}} +test oo-35.6 { + Bug : teardown of an object that is a class that is an instance of itself +} -setup { + oo::class create obj + + oo::copy obj obj1 obj1 + oo::objdefine obj1 { + mixin obj1 obj + } + oo::copy obj1 obj2 + oo::objdefine obj2 { + mixin obj2 obj1 + } +} -body { + rename obj2 {} + rename obj1 {} + # doesn't crash + return done +} -cleanup { + rename obj {} +} -result done + +test oo-36.1 {TIP #470: introspection within oo::define} { + oo::define oo::object self +} ::oo::object +test oo-36.2 {TIP #470: introspection within oo::define} -setup { + oo::class create Cls +} -body { + oo::define Cls self +} -cleanup { + Cls destroy +} -result ::Cls +test oo-36.3 {TIP #470: introspection within oo::define} -setup { + oo::class create Super + set result uncalled +} -body { + oo::class create Sub { + superclass Super + ::set ::result [self] + } + return $result +} -cleanup { + Super destroy +} -result ::Sub +test oo-36.4 {TIP #470: introspection within oo::define} -setup { + oo::class create Super + set result uncalled +} -body { + oo::class create Sub { + superclass Super + ::set ::result [self {}] + } + return $result +} -cleanup { + Super destroy +} -result {} +test oo-36.5 {TIP #470: introspection within oo::define} -setup { + oo::class create Super + set result uncalled +} -body { + oo::class create Sub { + superclass Super + ::set ::result [self self] + } +} -cleanup { + Super destroy +} -result ::Sub +test oo-36.6 {TIP #470: introspection within oo::objdefine} -setup { + oo::class create Cls + set result uncalled +} -body { + Cls create obj + oo::objdefine obj { + ::set ::result [self] + } +} -cleanup { + Cls destroy +} -result ::obj +test oo-36.7 {TIP #470: introspection within oo::objdefine} -setup { + oo::class create Cls +} -body { + Cls create obj + oo::objdefine obj { + self + } +} -cleanup { + Cls destroy +} -result ::obj +test oo-36.8 {TIP #470: introspection within oo::objdefine} -setup { + oo::class create Cls +} -body { + Cls create obj + oo::objdefine obj { + self anything + } +} -returnCodes error -cleanup { + Cls destroy +} -result {wrong # args: should be "self"} +test oo-36.9 {TIP #470: introspection within oo::define} -setup { + oo::class create Cls + set result uncalled +} -body { + proc oo::define::testself {} { + global result + set result [list [catch {self} msg] $msg \ + [catch {uplevel 1 self} msg] $msg] + return + } + list [oo::define Cls testself] $result +} -cleanup { + Cls destroy + catch {rename oo::define::testself {}} +} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::Cls}} +test oo-36.10 {TIP #470: introspection within oo::define} -setup { + oo::class create Cls + set result uncalled +} -body { + proc oo::objdefine::testself {} { + global result + set result [list [catch {self} msg] $msg \ + [catch {uplevel 1 self} msg] $msg] + return + } + Cls create obj + list [oo::objdefine obj testself] $result +} -cleanup { + Cls destroy + catch {rename oo::objdefine::testself {}} +} -result {{} {1 {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} 0 ::obj}} + +test oo-37.1 {TIP 500: private command propagates errors} -setup { + oo::class create cls +} -body { + oo::define cls { + private ::error "this is an error" + } +} -cleanup { + cls destroy +} -returnCodes error -result {this is an error} +test oo-37.2 {TIP 500: private command propagates errors} -setup { + oo::class create cls +} -body { + oo::define cls { + private { + ::error "this is an error" + } + } +} -cleanup { + cls destroy +} -returnCodes error -result {this is an error} +test oo-37.3 {TIP 500: private command propagates errors} -setup { + oo::object create obj +} -body { + oo::objdefine obj { + private ::error "this is an error" + } +} -cleanup { + obj destroy +} -returnCodes error -result {this is an error} +test oo-37.4 {TIP 500: private command propagates errors} -setup { + oo::object create obj +} -body { + oo::objdefine obj { + private { + ::error "this is an error" + } + } +} -cleanup { + obj destroy +} -returnCodes error -result {this is an error} +test oo-37.5 {TIP 500: private command can't be used outside definitions} -body { + oo::define::private error "xyz" +} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} +test oo-37.6 {TIP 500: private command can't be used outside definitions} -body { + oo::objdefine::private error "xyz" +} -returnCodes error -result {this command may only be called from within the context of an ::oo::define or ::oo::objdefine command} + +test oo-38.1 {TIP 500: private variables don't cross-interfere with each other or normal ones} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + private variable x + constructor {} { + set x 1 + } + method getA {} { + return $x + } + } + oo::class create clsB { + superclass clsA + private { + variable x + } + constructor {} { + set x 2 + next + } + method getB {} { + return $x + } + } + oo::class create clsC { + superclass clsB + variable x + constructor {} { + set x 3 + next + } + method getC {} { + return $x + } + } + clsC create obj + oo::objdefine obj { + private { + variable x + } + method setup {} { + set x 4 + } + method getO {} { + return $x + } + } + obj setup + list [obj getA] [obj getB] [obj getC] [obj getO] \ + [lsort [string map [list [info object creationid clsA] CLASS-A \ + [info object creationid clsB] CLASS-B \ + [info object creationid obj] OBJ] \ + [info object vars obj]]] +} -cleanup { + parent destroy +} -result {1 2 3 4 {{CLASS-A : x} {CLASS-B : x} {OBJ : x} x}} +test oo-38.2 {TIP 500: private variables introspection} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + private { + variable x1 + variable x2 + } + variable y1 y2 + } + cls create obj + oo::objdefine obj { + private variable a1 a2 + variable b1 b2 + } + list [lsort [info class variables cls]] \ + [lsort [info class variables cls -private]] \ + [lsort [info object variables obj]] \ + [lsort [info object variables obj -private]] +} -cleanup { + parent destroy +} -result {{y1 y2} {x1 x2} {b1 b2} {a1 a2}} +test oo-38.3 {TIP 500: private variables and oo::object·varname} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + private { + variable x + } + method getx {} { + set x 1 + my varname x + } + method readx {} { + return $x + } + } + oo::class create clsB { + superclass clsA + variable x + method gety {} { + set x 1 + my varname x + } + method ready {} { + return $x + } + } + clsB create obj + set [obj getx] 2 + set [obj gety] 3 + list [obj readx] [obj ready] +} -cleanup { + parent destroy +} -result {2 3} +test oo-38.4 {TIP 500: private variables introspection} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + private { + variable x1 x2 + } + variable y1 y2 + constructor {} { + variable z boo + set x1 a + set y1 c + } + method list {} { + variable z + set ok 1 + list [info locals] [lsort [info vars]] [info exist x2] + } + } + cls create obj + oo::objdefine obj { + private variable a1 a2 + variable b1 b2 + method init {} { + # Because we don't have a constructor to do this setup for us + set a1 p + set b1 r + } + method list {} { + variable z + set yes 1 + list {*}[next] [info locals] [lsort [info vars]] [info exist a2] + } + } + obj init + obj list +} -cleanup { + parent destroy +} -result {ok {ok x1 x2 y1 y2 z} 0 yes {a1 a2 b1 b2 yes z} 0} +test oo-38.5 {TIP 500: private variables and oo::object·variable} -setup { + oo::class create parent +} -body { + oo::class create cls1 { + superclass parent + private variable x + method abc val { + my variable x + set x $val + } + method def val { + my variable y + set y $val + } + method get1 {} { + my variable x y + return [list $x $y] + } + } + oo::class create cls2 { + superclass cls1 + private variable x + method x-exists {} { + return [info exists x],[uplevel 1 {info exists x}] + } + method ghi x { + # Additional instrumentation to show that we're not using the + # resolved variable until we ask for it; the argument nixed that + # happening by default. + set val $x + set before [my x-exists] + unset x + set x $val + set mid [my x-exists] + unset x + set mid2 [my x-exists] + my variable x + set x $val + set after [my x-exists] + return "$before;$mid;$mid2;$after" + } + method jkl val { + my variable y + set y $val + } + method get2 {} { + my variable x y + return [list $x $y] + } + } + cls2 create a + a abc 123 + a def 234 + set tmp [a ghi 345] + a jkl 456 + list $tmp [a get1] [a get2] +} -cleanup { + parent destroy +} -result {{0,1;0,1;0,0;1,1} {123 456} {345 456}} + +test oo-39.1 {TIP 500: private methods internal call; class private} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + variable x + constructor {} { + set x 1 + } + method act {} { + my step + my step + my step + return + } + private { + method step {} { + incr x 2 + } + } + method x {} { + return $x + } + } + clsA create obj + obj act + list [obj x] [catch {obj step} msg] $msg +} -cleanup { + parent destroy +} -result {7 1 {unknown method "step": must be act, destroy or x}} +test oo-39.2 {TIP 500: private methods internal call; class private} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + variable x + constructor {} { + set x 1 + } + method act {} { + my step + my step + my step + return + } + private { + method step {} { + incr x 2 + } + } + method x {} { + return $x + } + } + oo::class create clsB { + superclass clsA + variable x + method step {} { + incr x 5 + } + } + clsB create obj + obj act + list [obj x] [obj step] +} -cleanup { + parent destroy +} -result {7 12} +test oo-39.3 {TIP 500: private methods internal call; class private} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + variable x + constructor {} { + set x 1 + } + method act {} { + my Step + my Step + my Step + return + } + method x {} { + return $x + } + } + oo::class create clsB { + superclass clsA + variable x + method Step {} { + incr x 5 + } + } + clsB create obj + obj act + set result [obj x] + oo::define clsA { + private { + method Step {} { + incr x 2 + } + } + } + obj act + lappend result [obj x] +} -cleanup { + parent destroy +} -result {16 22} +test oo-39.4 {TIP 500: private methods internal call; instance private} -setup { + oo::class create parent +} -body { + oo::class create clsA { + superclass parent + variable x + constructor {} { + set x 1 + } + method act {} { + my step + return + } + method step {} { + incr x + } + method x {} { + return $x + } + } + clsA create obj + obj act + set result [obj x] + oo::objdefine obj { + variable x + private { + method step {} { + incr x 2 + } + } + } + obj act + lappend result [obj x] + oo::objdefine obj { + method act {} { + my step + next + } + } + obj act + lappend result [obj x] +} -cleanup { + parent destroy +} -result {2 3 6} +test oo-39.5 {TIP 500: private methods internal call; cross object} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + method equal {other} { + expr {$x == [$other x]} + } + } + cls create a 1 + cls create b 2 + cls create c 1 + list [a equal b] [b equal c] [c equal a] [catch {a x} msg] $msg +} -cleanup { + parent destroy +} -result {0 0 1 1 {unknown method "x": must be destroy or equal}} +test oo-39.6 {TIP 500: private methods internal call; error reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + method equal {other} { + expr {$x == [$other y]} + } + } + cls create a 1 + cls create b 2 + a equal b +} -returnCodes error -cleanup { + parent destroy +} -result {unknown method "y": must be destroy, equal or x} +test oo-39.7 {TIP 500: private methods internal call; error reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + method equal {other} { + expr {[[self] y] == [$other x]} + } + } + cls create a 1 + cls create b 2 + a equal b +} -returnCodes error -cleanup { + parent destroy +} -result {unknown method "y": must be destroy, equal or x} +test oo-39.8 {TIP 500: private methods internal call; error reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + method equal {other} { + expr {[my y] == [$other x]} + } + } + cls create a 1 + cls create b 2 + a equal b +} -returnCodes error -cleanup { + parent destroy +} -result {unknown method "y": must be <cloned>, destroy, equal, eval, unknown, variable, varname or x} +test oo-39.9 {TIP 500: private methods internal call; error reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + } + oo::class create cls2 { + superclass cls + method equal {other} { + expr {[my y] == [$other x]} + } + } + cls2 create a 1 + cls2 create b 2 + a equal b +} -returnCodes error -cleanup { + parent destroy +} -result {unknown method "y": must be <cloned>, destroy, equal, eval, unknown, variable or varname} +test oo-39.10 {TIP 500: private methods internal call; error reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + variable x + constructor {val} { + set x $val + } + private method x {} { + return $x + } + } + oo::class create cls2 { + superclass cls + method equal {other} { + expr {[my x] == [$other x]} + } + } + cls2 create a 1 + cls2 create b 2 + a equal b +} -returnCodes error -cleanup { + parent destroy +} -result {unknown method "x": must be <cloned>, destroy, equal, eval, unknown, variable or varname} +test oo-39.11 {TIP 500: private methods; call chain caching and reporting} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + method chain {} { + return [self call] + } + } + oo::class create cls2 { + superclass cls + private method chain {} { + next + } + method chain2 {} { + my chain + } + method chain3 {} { + [self] chain + } + } + cls create a + cls2 create b + list [a chain] [b chain] [b chain2] [b chain3] +} -cleanup { + parent destroy +} -result {{{{method chain ::cls method}} 0} {{{method chain ::cls method}} 0} {{{private chain ::cls2 method} {method chain ::cls method}} 1} {{{private chain ::cls2 method} {method chain ::cls method}} 1}} +test oo-39.12 {TIP 500: private methods; introspection} -setup { + oo::class create parent +} -body { + oo::class create cls { + superclass parent + method chain {} { + return [self call] + } + private method abc {} {} + } + oo::class create cls2 { + superclass cls + method chain2 {} { + my chain + } + method chain3 {} { + [self] chain + } + private method def {} {} + unexport chain3 + } + cls create a + cls2 create b + oo::objdefine b { + private method ghi {} {} + method ABC {} {} + method foo {} {} + } + set scopes {public unexported private} + list a: [lmap s $scopes {info object methods a -scope $s}] \ + b: [lmap s $scopes {info object methods b -scope $s}] \ + cls: [lmap s $scopes {info class methods cls -scope $s}] \ + cls2: [lmap s $scopes {info class methods cls2 -scope $s}] \ +} -cleanup { + parent destroy +} -result {a: {{} {} {}} b: {foo ABC ghi} cls: {chain {} abc} cls2: {chain2 chain3 def}} + +test oo-40.1 {TIP 500: private and self} -setup { + oo::class create cls +} -body { + oo::define cls { + self { + private { + variable a + } + variable b + } + private { + self { + variable c + } + variable d + } + variable e + } + list \ + [lsort [info class variables cls]] \ + [lsort [info class variables cls -private]] \ + [lsort [info object variables cls]] \ + [lsort [info object variables cls -private]] +} -cleanup { + cls destroy +} -result {e d b {a c}} +test oo-40.2 {TIP 500: private and export} -setup { + oo::class create cls +} -body { + oo::define cls { + private method foo {} {} + } + set result [lmap s {public unexported private} { + info class methods cls -scope $s}] + oo::define cls { + export foo + } + lappend result {*}[lmap s {public unexported private} { + info class methods cls -scope $s}] +} -cleanup { + cls destroy +} -result {{} {} foo foo {} {}} +test oo-40.3 {TIP 500: private and unexport} -setup { + oo::class create cls +} -body { + oo::define cls { + private method foo {} {} + } + set result [lmap s {public unexported private} { + info class methods cls -scope $s}] + oo::define cls { + unexport foo + } + lappend result {*}[lmap s {public unexported private} { + info class methods cls -scope $s}] +} -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 bc73003..2dca06b 100644 --- a/tests/package.test +++ b/tests/package.test @@ -17,16 +17,22 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +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 +catch [list load {} Tcltest $i] interp eval $i { namespace import -force ::tcltest::* -package forget {*}[package names] +#package forget {*}[package names] set oldPkgUnknown [package unknown] package unknown {} set oldPath $auto_path set auto_path "" + +testConstraint testpreferstable [llength [info commands testpreferstable]] test package-1.1 {pkg::create gives error on insufficient args} -body { ::pkg::create @@ -134,7 +140,7 @@ test package-3.1 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {3.4} test package-3.2 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t @@ -144,7 +150,7 @@ test package-3.2 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {3.5} test package-3.3 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t @@ -154,7 +160,7 @@ test package-3.3 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require t 2.2 - return $x + set x } -result {2.3} test package-3.4 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t @@ -164,7 +170,7 @@ test package-3.4 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require -exact t 2.3 - return $x + set x } -result {2.3} test package-3.5 {Tcl_PkgRequire procedure, picking best version} -setup { package forget t @@ -174,7 +180,7 @@ test package-3.5 {Tcl_PkgRequire procedure, picking best version} -setup { package ifneeded t $i "set x $i; package provide t $i" } package require t 2.1 - return $x + set x } -result {2.4} test package-3.6 {Tcl_PkgRequire procedure, can't find suitable version} -setup { package forget t @@ -233,7 +239,7 @@ test package-3.12 {Tcl_PkgRequire procedure, self-deleting script} -setup { } -body { package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2" package require t 1.2 - return $x + set x } -result {1.2} test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup { package forget t @@ -251,7 +257,7 @@ test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup { } package unknown pkgUnknown package require -exact t 1.5 - return $x + set x } -cleanup { package unknown {} } -result {t 1.5-1.5} @@ -278,7 +284,7 @@ test package-3.15 {Tcl_PkgRequire procedure, "package unknown" support} -setup { package provide [lindex $args 0] 2.0 } package require {a b} - return $x + set x } -cleanup { package unknown {} } -result {{a b} 0-} @@ -569,15 +575,24 @@ test package-3.44 {Tcl_PkgRequire: exact version matching (1578344)} -setup { } -returnCodes error -cleanup { package forget demo } -result {version conflict for package "demo": have 1.2.3, need exactly 1.2} -test package-3.50 {Tcl_PkgRequire procedure, picking best stable version} -setup { +test package-3.50 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup { + interp create child + load {} Tcltest child + child eval { + testpreferstable package forget t set x xxx + } } -body { + child eval { foreach i {1.4 3.4 4.0a1 2.3 2.4 2.2} { package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x + } +} -cleanup { + interp delete child } -result {3.4} test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup { package forget t @@ -587,7 +602,7 @@ test package-3.51 {Tcl_PkgRequire procedure, picking best stable version} -setup package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {1.3} test package-3.52 {Tcl_PkgRequire procedure, picking best stable version} -setup { package forget t @@ -597,56 +612,81 @@ test package-3.52 {Tcl_PkgRequire procedure, picking best stable version} -setup package ifneeded t $i "set x $i; package provide t $i" } package require t - return $x + set x } -result {1.3} -test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} { +test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} -constraints testpreferstable -setup { + testpreferstable package forget t + set x xxx +} -body { foreach i {1.2b1 1.1} { package ifneeded t $i "set x $i; package provide t $i" } - set x xxx package require t set x -} {1.1} +} -result {1.1} test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup { package forget t } -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 { package } -result {wrong # args: should be "package option ?arg ...?"} -test package-4.2 {Tcl_PackageCmd procedure, "forget" option} { +test package-4.2 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package names -} {} -test package-4.3 {Tcl_PackageCmd procedure, "forget" option} { + } +} -cleanup { + interp delete child +} -result {} +test package-4.3 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package forget foo -} {} + } +} -cleanup { + interp delete child +} -result {} test package-4.4 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child + child eval { package forget {*}[package names] set result {} + } } -body { + child eval { package ifneeded t 1.1 {first script} package ifneeded t 2.3 {second script} package ifneeded x 1.4 {x's script} lappend result [lsort [package names]] [package versions t] package forget t lappend result [lsort [package names]] [package versions t] + } +} -cleanup { + interp delete child } -result {{t x} {1.1 2.3} x {}} test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup { + interp create child + child eval { package forget {*}[package names] + } } -body { + child eval { package ifneeded a 1.1 {first script} package ifneeded b 2.3 {second script} package ifneeded c 1.4 {third script} @@ -654,6 +694,9 @@ test package-4.5 {Tcl_PackageCmd procedure, "forget" option} -setup { set result [list [lsort [package names]]] package forget a c lappend result [lsort [package names]] + } +} -cleanup { + interp delete child } -result {{a b c} b} test package-4.5.1 {Tcl_PackageCmd procedure, "forget" option} -body { # Test for Bug 415273 @@ -672,28 +715,55 @@ test package-4.7 {Tcl_PackageCmd procedure, "ifneeded" option} -body { test package-4.8 {Tcl_PackageCmd procedure, "ifneeded" option} -body { package ifneeded t xyz } -returnCodes error -result {expected version number but got "xyz"} -test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} { +test package-4.9 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] list [package ifneeded foo 1.1] [package names] -} {{} {}} + } +} -cleanup { + interp delete child +} -result {{} {}} test package-4.10 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" list [package names] [package ifneeded t 1.4] [package versions t] + } +} -cleanup { + interp delete child } -result {t {script for t 1.4} 1.4} test package-4.11 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" list [package ifneeded t 1.5] [package names] [package versions t] + } +} -cleanup { + interp delete child } -result {{} t 1.4} test package-4.12 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { - package forget t + interp create child + child eval { + package forget {*}[package names] + } } -body { + child eval { package ifneeded t 1.4 "script for t 1.4" package ifneeded t 1.4 "second script for t 1.4" list [package ifneeded t 1.4] [package names] [package versions t] + } +} -cleanup { + interp delete child } -result {{second script for t 1.4} t 1.4} test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { package forget t @@ -706,18 +776,31 @@ test package-4.13 {Tcl_PackageCmd procedure, "ifneeded" option} -setup { test package-4.14 {Tcl_PackageCmd procedure, "names" option} -body { package names a } -returnCodes error -result {wrong # args: should be "package names"} -test package-4.15 {Tcl_PackageCmd procedure, "names" option} { +test package-4.15 {Tcl_PackageCmd procedure, "names" option} -setup { + interp create child +} -body { + child eval { package forget {*}[package names] package names -} {} + } +} -cleanup { + interp delete child +} -result {} test package-4.16 {Tcl_PackageCmd procedure, "names" option} -setup { + interp create child + child eval { package forget {*}[package names] + } } -body { + child eval { package ifneeded x 1.2 {dummy} package provide x 1.3 package provide y 2.4 catch {package require z 47.16} lsort [package names] + } +} -cleanup { + interp delete child } -result {x y} test package-4.17 {Tcl_PackageCmd procedure, "provide" option} -body { package provide @@ -848,7 +931,7 @@ test package-4.52 {Tcl_PackageCmd procedure, "vsatisfies" option} { } {0} test package-4.53 {Tcl_PackageCmd procedure, "versions" option} -body { package foo -} -returnCodes error -result {bad option "foo": must be forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies} +} -returnCodes error -result {bad option "foo": must be files, forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies} test package-4.54 {Tcl_PackageCmd procedure, "vsatisfies" option} -body { package vsatisfies 2.1 2.1-3.2-4.5 } -returnCodes error -result {expected versionMin-versionMax but got "2.1-3.2-4.5"} @@ -1255,9 +1338,9 @@ proc prefer {args} { } } -test package-13.0 {package prefer defaults} { +test package-13.0 {package prefer defaults} -body { prefer -} stable +} -result [expr {[string match {*[ab]*} [package provide Tcl]] ? "latest" : "stable"}] test package-13.1 {package prefer defaults} -body { set ::env(TCL_PKG_PREFER_LATEST) stable ;# value not relevant! prefer @@ -1272,15 +1355,27 @@ test package-14.1 {bogus argument} -returnCodes error -body { package prefer foo } -result {bad preference "foo": must be latest or stable} -test package-15.0 {set, keep} {package prefer stable} stable -test package-15.1 {set stable, keep} {prefer stable} {stable stable} -test package-15.2 {set latest, change} {prefer latest} {stable latest} -test package-15.3 {set latest, keep} { - prefer latest latest -} {stable latest latest} -test package-15.4 {set stable, rejected} { - prefer latest stable -} {stable latest latest} +test package-15.0 {set, keep} -constraints testpreferstable -setup { + testpreferstable +} -body {package prefer} -result stable +test package-15.1 {set stable, keep} -constraints testpreferstable -setup { + testpreferstable +} -body {package prefer stable} -result stable +test package-15.2 {set latest, change} -constraints testpreferstable -setup { + testpreferstable +} -body {package prefer latest} -result latest +test package-15.3 {set latest, keep} -constraints testpreferstable -setup { + testpreferstable +} -body { + package prefer latest + package prefer latest +} -result latest +test package-15.4 {set stable, rejected} -constraints testpreferstable -setup { + testpreferstable +} -body { + package prefer latest + package prefer stable +} -result latest rename prefer {} diff --git a/tests/parse.test b/tests/parse.test index d73c725..287c392 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -369,7 +369,7 @@ test parse-8.8 {Tcl_EvalObjv procedure, async handlers} -constraints { variable ::aresult variable ::acode proc async1 {result code} { - variable ::aresult + variable ::aresult variable ::acode set aresult $result set acode $code diff --git a/tests/parseExpr.test b/tests/parseExpr.test index ef05454..47dbec5 100644 --- a/tests/parseExpr.test +++ b/tests/parseExpr.test @@ -768,11 +768,11 @@ test parseExpr-21.8 {error messages} -body { expr {0o8x} } -returnCodes error -match glob -result {*invalid octal number*} test parseExpr-21.9 {error messages} -body { - expr {"} + expr {"} } -returnCodes error -result {missing " in expression """} test parseExpr-21.10 {error messages} -body { - expr \{ + expr \{ } -returnCodes error -result "missing close-brace in expression \"\{\"" test parseExpr-21.11 {error messages} -body { @@ -1044,9 +1044,8 @@ test parseExpr-22.13 {Bug 3401704} -constraints testexprparser -body { } -result {- {} 0 subexpr naner() 1 operator naner 0 {}} test parseExpr-22.14 {Bug 3401704} -constraints testexprparser -body { - catch {testexprparser 08 -1} m o - dict get $o -errorcode -} -result {TCL PARSE EXPR BADNUMBER OCTAL} + testexprparser 07 -1 +} -result {- {} 0 subexpr 07 1 text 07 0 {}} test parseExpr-22.15 {Bug 3401704} -constraints testexprparser -body { catch {testexprparser 0o8 -1} m o dict get $o -errorcode 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/pkgMkIndex.test b/tests/pkgMkIndex.test index 84c82ce..8ff806c 100644 --- a/tests/pkgMkIndex.test +++ b/tests/pkgMkIndex.test @@ -231,7 +231,7 @@ proc pkgtest::runCreatedIndex {rv args} { set result [list 0 [makePkgList [parseIndex $idxFile]]] } err]} { set result [list 1 $err] - } + } file delete $idxFile } else { set result $rv diff --git a/tests/platform.test b/tests/platform.test index 8ee0ec7..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,27 +40,20 @@ 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 test platform-3.1 {CPU ID on Windows/UNIX} \ -constraints testCPUID \ - -body { + -body { set cpudata [testcpuid 0] binary format iii \ [lindex $cpudata 1] \ [lindex $cpudata 3] \ - [lindex $cpudata 2] + [lindex $cpudata 2] } \ -match regexp \ -result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$} @@ -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 e06720e..1893d0f 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -99,7 +99,7 @@ test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or e test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} -setup { catch {rename p ""} } -returnCodes error -body { - proc p {a(1) a(2)} { + proc p {a(1) a(2)} { set z [expr $a(1)+$a(2)] puts "$z=z, $a(1)=$a(1)" } @@ -107,9 +107,17 @@ test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array e test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} -setup { catch {rename p ""} } -body { - proc p {b:a b::a} { + 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_*]} @@ -329,7 +337,7 @@ test proc-5.1 {Bytecompiling noop; test for correct argument substitution} -body } -cleanup { catch {rename p ""} catch {rename t ""} -} -result {aba} +} -result {aba} test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} -body { proc a {} {return -code -5} @@ -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 new file mode 100644 index 0000000..5aa8354 --- /dev/null +++ b/tests/process.test @@ -0,0 +1,284 @@ +# process.test -- +# +# This file contains a collection of tests for the tcl::process ensemble. +# Sourcing this file into Tcl runs the tests and generates output for +# errors. No output means no errors were found. +# +# Copyright (c) 2017 Frederic Bonnet +# 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 + namespace import -force ::tcltest::* +} + +# Utilities +set path(sleep) [makeFile { + after [expr $argv*1000] + exit +} sleep] +set path(exit) [makeFile { + exit $argv +} exit] + +# Basic syntax checking +test process-1.1 {tcl::process command basic syntax} -returnCodes error -body { + tcl::process +} -result {wrong # args: should be "tcl::process subcommand ?arg ...?"} +test process-1.2 {tcl::process subcommands} -returnCodes error -body { + tcl::process ? +} -match glob -result {unknown or ambiguous subcommand "?": must be autopurge, list, purge, or status} + +# Autopurge flag +# - Default state +test process-2.1 {autopurge default} -body { + tcl::process autopurge +} -result {1} +# - Enabling autopurge +test process-2.2 {enable autopurge} -body { + tcl::process autopurge true + tcl::process autopurge +} -result {1} +# - Disabling autopurge +test process-2.3 {disable autopurge} -body { + tcl::process autopurge false + tcl::process autopurge +} -result {0} -cleanup {tcl::process autopurge true} + +# Subprocess list & status +test process-3.1 {empty subprocess list} -body { + llength [tcl::process list] +} -result {0} +test process-3.2 {empty subprocess status} -body { + dict size [tcl::process status] +} -result {0} + +# Spawn subprocesses using [exec] +# - One child +test process-4.1 {exec one child} -body { + tcl::process autopurge 0 + set pid [exec [interpreter] $path(exit) 0 &] + set list [tcl::process list] + set statuses [tcl::process status -wait] + set status [lindex [tcl::process status $pid] 1] + expr { + [llength $list] eq 1 + && [lindex $list 0] eq $pid + && [dict size $statuses] eq 1 + && [dict get $statuses $pid] eq $status + && $status eq 0 + } +} -result {1} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} +# - Two children +test process-4.2 {exec two children in parallel} -body { + tcl::process autopurge 0 + set pid1 [exec [interpreter] $path(exit) 0 &] + set pid2 [exec [interpreter] $path(exit) 0 &] + set list [tcl::process list] + set statuses [tcl::process status -wait] + set status1 [lindex [tcl::process status $pid1] 1] + set status2 [lindex [tcl::process status $pid2] 1] + expr { + [llength $list] eq 2 + && [lsearch $list $pid1] >= 0 + && [lsearch $list $pid2] >= 0 + && [dict size $statuses] eq 2 + && [dict get $statuses $pid1] eq $status1 + && [dict get $statuses $pid2] eq $status2 + && $status1 eq 0 + && $status2 eq 0 + } +} -result {1} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} +# - 3-stage pipe +test process-4.3 {exec 3-stage pipe} -body { + tcl::process autopurge 0 + set pids [exec \ + [interpreter] $path(exit) 0 \ + | [interpreter] $path(exit) 0 \ + | [interpreter] $path(exit) 0 \ + &] + lassign $pids pid1 pid2 pid3 + set list [tcl::process list] + set statuses [tcl::process status -wait] + set status1 [lindex [tcl::process status $pid1] 1] + set status2 [lindex [tcl::process status $pid2] 1] + set status3 [lindex [tcl::process status $pid3] 1] + expr { + [llength $pids] eq 3 + && [llength $list] eq 3 + && [lsearch $list $pid1] >= 0 + && [lsearch $list $pid2] >= 0 + && [lsearch $list $pid3] >= 0 + && [dict size $statuses] eq 3 + && [dict get $statuses $pid1] eq $status1 + && [dict get $statuses $pid2] eq $status2 + && [dict get $statuses $pid3] eq $status3 + && $status1 eq 0 + && $status2 eq 0 + && $status3 eq 0 + } +} -result {1} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} + +# Spawn subprocesses using [open "|"] +# - One child +test process-5.1 {exec one child} -body { + tcl::process autopurge 0 + set f [open "|\"[interpreter]\" \"$path(exit)\" 0"] + set pid [pid $f] + set list [tcl::process list] + set statuses [tcl::process status -wait] + set status [lindex [tcl::process status $pid] 1] + expr { + [llength $list] eq 1 + && [lindex $list 0] eq $pid + && [dict size $statuses] eq 1 + && [dict get $statuses $pid] eq $status + && $status eq 0 + } +} -result {1} -cleanup { + close $f + tcl::process purge + tcl::process autopurge 1 +} +# - Two children +test process-5.2 {exec two children in parallel} -body { + tcl::process autopurge 0 + set f1 [open "|\"[interpreter]\" \"$path(exit)\" 0"] + set f2 [open "|\"[interpreter]\" \"$path(exit)\" 0"] + set pid1 [pid $f1] + set pid2 [pid $f2] + set list [tcl::process list] + set statuses [tcl::process status -wait] + set status1 [lindex [tcl::process status $pid1] 1] + set status2 [lindex [tcl::process status $pid2] 1] + expr { + [llength $list] eq 2 + && [lsearch $list $pid1] >= 0 + && [lsearch $list $pid2] >= 0 + && [dict size $statuses] eq 2 + && [dict get $statuses $pid1] eq $status1 + && [dict get $statuses $pid2] eq $status2 + && $status1 eq 0 + && $status2 eq 0 + } +} -result {1} -cleanup { + close $f1 + close $f2 + tcl::process purge + tcl::process autopurge 1 +} +# - 3-stage pipe +test process-5.3 {exec 3-stage pipe} -body { + tcl::process autopurge 0 + set f [open "| + \"[interpreter]\" \"$path(exit)\" 0 + | \"[interpreter]\" \"$path(exit)\" 0 + | \"[interpreter]\" \"$path(exit)\" 0 + "] + set pids [pid $f] + lassign $pids pid1 pid2 pid3 + set list [tcl::process list] + set statuses [tcl::process status -wait] + set status1 [lindex [tcl::process status $pid1] 1] + set status2 [lindex [tcl::process status $pid2] 1] + set status3 [lindex [tcl::process status $pid3] 1] + expr { + [llength $pids] eq 3 + && [llength $list] eq 3 + && [lsearch $list $pid1] >= 0 + && [lsearch $list $pid2] >= 0 + && [lsearch $list $pid3] >= 0 + && [dict size $statuses] eq 3 + && [dict get $statuses $pid1] eq $status1 + && [dict get $statuses $pid2] eq $status2 + && [dict get $statuses $pid3] eq $status3 + && $status1 eq 0 + && $status2 eq 0 + && $status3 eq 0 + } +} -result {1} -cleanup { + close $f + tcl::process purge + tcl::process autopurge 1 +} + +# Async child status +test process-6.1 {async status} -body { + tcl::process autopurge 0 + set pid [exec [interpreter] $path(sleep) 1 &] + set status1 [lindex [tcl::process status $pid] 1] + set status2 [lindex [tcl::process status -wait $pid] 1] + expr { + $status1 eq {} + && $status2 eq 0 + } +} -result {1} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} +test process-6.2 {selective wait} -body { + tcl::process autopurge 0 + # Child 1 sleeps 1s + set pid1 [exec [interpreter] $path(sleep) 1 &] + # Child 2 sleeps 1s + set pid2 [exec [interpreter] $path(sleep) 2 &] + # Initial status + set status1_1 [lindex [tcl::process status $pid1] 1] + set status1_2 [lindex [tcl::process status $pid2] 1] + # Wait until child 1 termination + set status2_1 [lindex [tcl::process status -wait $pid1] 1] + set status2_2 [lindex [tcl::process status $pid2] 1] + # Wait until child 2 termination + set status3_2 [lindex [tcl::process status -wait $pid2] 1] + set status3_1 [lindex [tcl::process status $pid1] 1] + expr { + $status1_1 eq {} + && $status1_2 eq {} + && $status2_1 eq 0 + && $status2_2 eq {} + && $status3_1 eq 0 + && $status3_2 eq 0 + } +} -result {1} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} + +# Error codes +test process-7.1 {normal exit} -body { + tcl::process autopurge 0 + set pid [exec [interpreter] $path(exit) 0 &] + lindex [tcl::process status -wait $pid] 1 +} -result {0} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} +test process-7.2 {abnormal exit} -body { + tcl::process autopurge 0 + set pid [exec [interpreter] $path(exit) 1 &] + lindex [tcl::process status -wait $pid] 1 +} -match glob -result {1 {child process exited abnormally} {CHILDSTATUS * 1}} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} +test process-7.3 {child killed} -constraints {win} -body { + tcl::process autopurge 0 + set pid [exec [interpreter] $path(exit) -1 &] + lindex [tcl::process status -wait $pid] 1 +} -match glob -result {1 {child killed: unknown signal} {CHILDKILLED * {unknown signal} {unknown signal}}} -cleanup { + tcl::process purge + tcl::process autopurge 1 +} + +::tcltest::cleanupTests +return diff --git a/tests/reg.test b/tests/reg.test index d040632..b9dc538 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -49,9 +49,9 @@ catch [list package require -exact Tcltest [info patchlevel]] # subexpressions, checking where empty substrings are located, # etc. should be done using expectIndices and expectPartial. -# The flag characters are complex and a bit eclectic. Generally speaking, +# The flag characters are complex and a bit eclectic. Generally speaking, # lowercase letters are compile options, uppercase are expected re_info -# bits, and nonalphabetics are match options, controls for how the test is +# bits, and nonalphabetics are match options, controls for how the test is # run, or testing options. The one small surprise is that AREs are the # default, and you must explicitly request lesser flavors of RE. The flags # are as follows. It is admitted that some are not very mnemonic. @@ -311,7 +311,7 @@ namespace eval RETest { # match expected (full fanciness) # expectIndices testno flags re target mat submat ... proc expectIndices {args} { - MatchExpected -indices {*}$args + MatchExpected -indices {*}$args } # partial match expected diff --git a/tests/regexp.test b/tests/regexp.test index 9fff262..7367af7 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -19,6 +19,20 @@ if {"::tcltest" ni [namespace children]} { unset -nocomplain foo testConstraint exec [llength [info commands exec]] + +# Used for constraining memory leak tests +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc memtest script { + set end [lindex [split [memory info] \n] 3 3] + for {set i 0} {$i < 5} {incr i} { + uplevel 1 $script + set tmp $end + set end [lindex [split [memory info] \n] 3 3] + } + expr {$end - $tmp} + } +} test regexp-1.1 {basic regexp operation} { regexp ab*c abbbc @@ -453,7 +467,7 @@ test regexp-11.4 {regsub errors} { } {1 {wrong # args: should be "regsub ?-option ...? exp string subSpec ?varName?"}} test regexp-11.5 {regsub errors} { list [catch {regsub -gorp a b c} msg] $msg -} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} +} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} test regexp-11.6 {regsub errors} { list [catch {regsub -nocase a( b c d} msg] $msg } {1 {couldn't compile regular expression pattern: parentheses () not balanced}} @@ -480,7 +494,7 @@ test regexp-11.12 {regsub without final variable name returns value} { } {a,bcd,c,ea,bcfd,cf,e} # This test crashes on the Mac unless you increase the Stack Space to about 1 -# Meg. This is probably bigger than most users want... +# Meg. This is probably bigger than most users want... # 8.2.3 regexp reduced stack space requirements, but this should be # tested again test regexp-12.1 {Tcl_RegExpExec: large number of subexpressions} {macCrash} { @@ -742,10 +756,10 @@ test regexp-19.2 {regsub null replacement} { test regexp-20.1 {regsub shared object shimmering} { # Bug #461322 - set a abcdefghijklmnopqurstuvwxyz - set b $a - set c abcdefghijklmnopqurstuvwxyz0123456789 - regsub $a $c $b d + set a abcdefghijklmnopqurstuvwxyz + set b $a + set c abcdefghijklmnopqurstuvwxyz0123456789 + regsub $a $c $b d list $d [string length $d] [string bytelength $d] } [list abcdefghijklmnopqurstuvwxyz0123456789 37 37] test regexp-20.2 {regsub shared object shimmering with -about} { @@ -1123,6 +1137,57 @@ test regexp-26.12 {regexp with -line option} { test regexp-26.13 {regexp without -line option} { regexp -all -inline -- {a*} "b\n" } {{} {}} + +test regexp-27.1 {regsub -command} { + regsub -command {.x.} {abcxdef} {string length} +} ab3ef +test regexp-27.2 {regsub -command} { + regsub -command {.x.} {abcxdefxghi} {string length} +} ab3efxghi +test regexp-27.3 {regsub -command} { + set x 0 + regsub -all -command {(?=.)} abcde {apply {args {incr ::x}}} +} 1a2b3c4d5e +test regexp-27.4 {regsub -command} -body { + regsub -command {.x.} {abcxdef} error +} -returnCodes error -result cxd +test regexp-27.5 {regsub -command} { + regsub -command {(.)(.)} {abcdef} {list ,} +} {, ab a bcdef} +test regexp-27.6 {regsub -command} { + regsub -command -all {(.)(.)} {abcdef} {list ,} +} {, ab a b, cd c d, ef e f} +test regexp-27.7 {regsub -command representation smash} { + set ::s {123=456 789} + regsub -command -all {\d+} $::s {apply {n { + expr {[llength $::s] + $n} + }}} +} {125=458 791} +test regexp-27.8 {regsub -command representation smash} { + set ::t {apply {n { + expr {[llength [lindex $::t 1 1 1]] + $n} + }}} + regsub -command -all {\d+} "123=456 789" $::t +} {131=464 797} +test regexp-27.9 {regsub -command memory leak testing} memory { + set ::s "123=456 789" + set ::t {apply {n { + expr {[llength [lindex $::t 1 1 1]] + [llength $::s] + $n} + }}} + memtest { + regsub -command -all {\d+} $::s $::t + } +} 0 +test regexp-27.10 {regsub -command error cases} -returnCodes error -body { + regsub -command . abc "def \{ghi" +} -result {unmatched open brace in list} +test regexp-27.11 {regsub -command error cases} -returnCodes error -body { + regsub -command . abc {} +} -result {command prefix must be a list of at least one element} +test regexp-27.12 {regsub -command representation smash} { + set s {list (.+)} + regsub -command $s {list list} $s +} {(.+) {list list} list} # cleanup ::tcltest::cleanupTests diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 01ef06d..fbf8012 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -22,7 +22,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { proc evalInProc { script } { proc testProc {} $script set status [catch { - testProc + testProc } result] rename testProc {} return $result @@ -587,7 +587,7 @@ test regexpComp-11.5 {regsub errors} { evalInProc { list [catch {regsub -gorp a b c} msg] $msg } -} {1 {bad option "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}} +} {1 {bad option "-gorp": must be -all, -command, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}} test regexpComp-11.6 {regsub errors} { evalInProc { list [catch {regsub -nocase a( b c d} msg] $msg @@ -607,7 +607,7 @@ test regexpComp-11.8 {regsub errors, -start bad int check} { } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}} # This test crashes on the Mac unless you increase the Stack Space to about 1 -# Meg. This is probably bigger than most users want... +# Meg. This is probably bigger than most users want... # 8.2.3 regexp reduced stack space requirements, but this should be # tested again test regexpComp-12.1 {Tcl_RegExpExec: large number of subexpressions} {macCrash} { @@ -794,10 +794,10 @@ test regexpComp-19.1 {regsub null replacement} { test regexpComp-20.1 {regsub shared object shimmering} { evalInProc { # Bug #461322 - set a abcdefghijklmnopqurstuvwxyz - set b $a - set c abcdefghijklmnopqurstuvwxyz0123456789 - regsub $a $c $b d + set a abcdefghijklmnopqurstuvwxyz + set b $a + set c abcdefghijklmnopqurstuvwxyz0123456789 + regsub $a $c $b d list $d [string length $d] [string bytelength $d] } } [list abcdefghijklmnopqurstuvwxyz0123456789 37 37] diff --git a/tests/registry.test b/tests/registry.test index 2072559..539ba2d 100644 --- a/tests/registry.test +++ b/tests/registry.test @@ -19,7 +19,7 @@ testConstraint reg 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::regver [package require registry 1.3.2] + set ::regver [package require registry 1.3.3] }]} { testConstraint reg 1 } @@ -33,7 +33,7 @@ testConstraint english [expr { test registry-1.0 {check if we are testing the right dll} {win reg} { set ::regver -} {1.3.2} +} {1.3.3} test registry-1.1 {argument parsing for registry command} {win reg} { list [catch {registry} msg] $msg } {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}} @@ -283,7 +283,7 @@ test registry-4.7 {GetKeyNames: Unicode} {win reg english} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } "baz\u00c7bar blat" -test registry-4.8 {GetKeyNames: Unicode} {win reg nt} { +test registry-4.8 {GetKeyNames: Unicode} {win reg} { registry delete HKEY_CURRENT_USER\\TclFoobar registry set HKEY_CURRENT_USER\\TclFoobar\\baz\u30b7bar registry set HKEY_CURRENT_USER\\TclFoobar\\blat @@ -487,7 +487,7 @@ test registry-6.17 {GetValue: Unicode value names} {win reg} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } foobar -test registry-6.18 {GetValue: values with Unicode strings} {win reg nt} { +test registry-6.18 {GetValue: values with Unicode strings} {win reg} { registry set HKEY_CURRENT_USER\\TclFoobar val1 {foo ba\u30b7r baz} multi_sz set result [registry get HKEY_CURRENT_USER\\TclFoobar val1] registry delete HKEY_CURRENT_USER\\TclFoobar @@ -505,7 +505,7 @@ test registry-6.20 {GetValue: values with Unicode strings with embedded nulls} { registry delete HKEY_CURRENT_USER\\TclFoobar set result } "foo ba r baz" -test registry-6.21 {GetValue: very long value names and values} {pcOnly reg} { +test registry-6.21 {GetValue: very long value names and values} {win reg} { registry set HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383] [string repeat x 16383] multi_sz set result [registry get HKEY_CURRENT_USER\\TclFoobar [string repeat k 16383]] registry delete HKEY_CURRENT_USER\\TclFoobar @@ -604,7 +604,7 @@ test registry-9.3 {ParseKeyName: bad keys} -constraints {win reg} -body { test registry-9.4 {ParseKeyName: bad keys} -constraints {win reg} -body { registry values \\\\\\ } -returnCodes error -result {bad root name "": must be HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, or HKEY_DYN_DATA} -test registry-9.5 {ParseKeyName: bad keys} -constraints {win reg english nt} -body { +test registry-9.5 {ParseKeyName: bad keys} -constraints {win reg english} -body { registry values \\\\\\HKEY_CLASSES_ROOT } -returnCodes error -result {unable to open key: The network address is invalid.} test registry-9.6 {ParseKeyName: bad keys} -constraints {win reg} -body { diff --git a/tests/result.test b/tests/result.test index 9e8a66b..859e546 100644 --- a/tests/result.test +++ b/tests/result.test @@ -31,7 +31,7 @@ test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} { } {append result} test result-1.3 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult dynamic {set x 42} 0 -} {dynamic result notCalled present} +} {dynamic result presentOrFreed} test result-1.4 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult object {set x 42} 0 } {object result same} @@ -43,7 +43,7 @@ test result-1.6 {Tcl_SaveInterpResult} {testsaveresult} { } {42} test result-1.7 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult dynamic {set x 42} 1 -} {42 called missing} +} {42 presentOrFreed} test result-1.8 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult object {set x 42} 1 } {42 different} diff --git a/tests/safe.test b/tests/safe.test index 5ffdcc5..356e176 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -74,7 +74,7 @@ test safe-2.3 {creating safe interpreters, should have no unexpected aliases} -s lsort [a aliases] } -cleanup { interp delete a -} -result {::tcl::mathfunc::max ::tcl::mathfunc::min clock} +} -result {clock} test safe-3.1 {calling safe::interpInit is safe} -setup { catch {safe::interpDelete a} @@ -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 98c581b..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 @@ -557,8 +553,8 @@ test scan-5.19 {bigint scanning invalid} -setup { set a {}; } -body { list [scan "207698809136909011942886895" \ - %llu a] $a -} -returnCodes 1 -result {unsigned bignum scans are invalid} + %llu a] $a +} -result {1 207698809136909011942886895} test scan-6.1 {floating-point scanning} -setup { set a {}; set b {}; set c {}; set d {} diff --git a/tests/set-old.test b/tests/set-old.test index 6138ed8..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, 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} @@ -940,7 +940,7 @@ catch {rename foo {}} # cleanup ::tcltest::cleanupTests -return +return # Local Variables: # mode: tcl diff --git a/tests/set.test b/tests/set.test index 374ff7a..3c87000 100644 --- a/tests/set.test +++ b/tests/set.test @@ -561,7 +561,7 @@ catch {unset i} catch {unset x} catch {unset z} ::tcltest::cleanupTests -return +return # Local Variables: # mode: tcl diff --git a/tests/socket.test b/tests/socket.test index a3e5704..d3d56fa 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -60,8 +60,13 @@ # listening at port 2048. If all fails, a message is printed and the tests # using the remote server are not performed. -package require tcltest 2 -namespace import -force ::tcltest::* +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] # Some tests require the Thread package or exec command testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] @@ -86,6 +91,14 @@ proc randport {} { return $port } +# Check if testsocket testflags is available +testConstraint testsocket_testflags [expr {![catch { + set h [socket -async localhost [randport]] + testsocket testflags $h 0 + close $h + }]}] + + # Test the latency of tcp connections over the loopback interface. Some OSes # (e.g. NetBSD) seem to use the Nagle algorithm and delayed ACKs, so it takes # up to 200ms for a packet sent to localhost to arrive. We're measuring this @@ -280,13 +293,13 @@ test socket_$af-1.1 {arg parsing for socket command} -constraints [list socket s } -returnCodes error -result {no argument given for -server option} test socket_$af-1.2 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server foo -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} test socket_$af-1.3 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myaddr } -returnCodes error -result {no argument given for -myaddr option} test socket_$af-1.4 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myaddr $localhost -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} test socket_$af-1.5 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myport } -returnCodes error -result {no argument given for -myport option} @@ -295,19 +308,19 @@ test socket_$af-1.6 {arg parsing for socket command} -constraints [list socket s } -returnCodes error -result {expected integer but got "xxxx"} test socket_$af-1.7 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -myport 2522 -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} test socket_$af-1.8 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -froboz -} -returnCodes error -result {bad option "-froboz": must be -async, -myaddr, -myport, or -server} +} -returnCodes error -result {bad option "-froboz": must be -async, -myaddr, -myport, -reuseaddr, -reuseport, or -server} test socket_$af-1.9 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server foo -myport 2521 3333 } -returnCodes error -result {option -myport is not valid for servers} test socket_$af-1.10 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket host 2528 -junk -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} test socket_$af-1.11 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server callback 2520 -- -} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-myaddr addr? port"} +} -returnCodes error -result {wrong # args: should be "socket ?-myaddr addr? ?-myport myport? ?-async? host port" or "socket -server command ?-reuseaddr boolean? ?-reuseport boolean? ?-myaddr addr? port"} test socket_$af-1.12 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket foo badport } -returnCodes error -result {expected integer but got "badport"} @@ -317,6 +330,24 @@ test socket_$af-1.13 {arg parsing for socket command} -constraints [list socket test socket_$af-1.14 {arg parsing for socket command} -constraints [list socket supported_$af] -body { socket -server foo -async } -returnCodes error -result {cannot set -async option for server sockets} +test socket_$af-1.15 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseaddr yes 4242 +} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} +test socket_$af-1.16 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseaddr no 4242 +} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} +test socket_$af-1.17 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseaddr +} -returnCodes error -result {no argument given for -reuseaddr option} +test socket_$af-1.18 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseport yes 4242 +} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} +test socket_$af-1.19 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseport no 4242 +} -returnCodes error -result {options -reuseaddr and -reuseport are only valid for servers} +test socket_$af-1.20 {arg parsing for socket command} -constraints [list socket supported_$af] -body { + socket -reuseport +} -returnCodes error -result {no argument given for -reuseport option} set path(script) [makeFile {} script] @@ -2263,12 +2294,17 @@ test socket-14.11.0 {pending [socket -async] and nonblocking [puts], no listener unset x } -result {socket is not connected} -returnCodes 1 test socket-14.11.1 {pending [socket -async] and nonblocking [puts], no listener, flush} \ - -constraints {socket nonPortable} \ + -constraints {socket testsocket_testflags} \ -body { set sock [socket -async localhost [randport]] + # Set the socket in async test mode. + # The async connect will not be continued on the following fconfigure + # and puts/flush. Thus, the connect will fail after them. + testsocket testflags $sock 1 fconfigure $sock -blocking 0 puts $sock ok flush $sock + testsocket testflags $sock 0 fileevent $sock writable {set x 1} vwait x close $sock @@ -2375,6 +2411,19 @@ test socket-14.18 {bug c6ed4acfd8: running async socket connect made other conne catch {close $csock2} } -result {} +test socket-14.19 {tip 456 -- introduce the -reuseport option} \ + -constraints {socket} \ + -body { + proc accept {channel address port} {} + set port [randport] + set ssock1 [socket -server accept -reuseport yes $port] + set ssock2 [socket -server accept -reuseport yes $port] + return ok +} -cleanup { + catch {close $ssock1} + catch {close $ssock2} + } -result ok + set num 0 set x {localhost {socket} 127.0.0.1 {supported_inet} ::1 {supported_inet6}} diff --git a/tests/source.test b/tests/source.test index 0235bd1..8b146d3 100644 --- a/tests/source.test +++ b/tests/source.test @@ -12,8 +12,8 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {[catch {package require tcltest 2.1}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.1 required." +if {[catch {package require tcltest 2.5}]} { + puts stderr "Skipping tests in [info script]. tcltest 2.5 required." return } @@ -103,10 +103,9 @@ test source-2.6 {source error conditions} -setup { set sourcefile [makeFile {} _non_existent_] removeFile _non_existent_ } -body { - list [catch {source $sourcefile} msg] $msg $::errorCode -} -match listGlob -result [list 1 \ - {couldn't read file "*_non_existent_": no such file or directory} \ - {POSIX ENOENT {no such file or directory}}] + source $sourcefile +} -match glob -result {couldn't read file "*_non_existent_": no such file or directory} \ + -errorCode {POSIX ENOENT {no such file or directory}} test source-2.7 {utf-8 with BOM} -setup { set sourcefile [makeFile {} source.file] } -body { diff --git a/tests/split.test b/tests/split.test index 18055b3..2d180e0 100644 --- a/tests/split.test +++ b/tests/split.test @@ -43,7 +43,7 @@ test split-1.8 {basic split commands} { foreach f [split {]\n} {}] { append x $f } - return $x + return $x } foo } {]\n} diff --git a/tests/stack.test b/tests/stack.test index 13bc524..4c50f74 100644 --- a/tests/stack.test +++ b/tests/stack.test @@ -31,7 +31,7 @@ test stack-2.1 {maxNestingDepth reached on infinite recursion} -body { puts $msg } } -result {too many nested evaluations (infinite loop?)} - + # Make sure that there is enough stack to run regexp even if we're # close to the recursion limit. [Bug 947070] [Patch 746378] test stack-3.1 {enough room for regexp near recursion limit} -body { diff --git a/tests/string.test b/tests/string.test index a4797fa..822895c 100644 --- a/tests/string.test +++ b/tests/string.test @@ -20,277 +20,476 @@ if {[lsearch [namespace children] ::tcltest] == -1} { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] +# Helper commands to test various optimizations, code paths, and special cases. +proc makeByteArray {s} {binary format a* $s} +proc makeUnicode {s} {lindex [regexp -inline .* $s] 0} +proc makeList {args} {return $args} +proc makeShared {s} {uplevel 1 [list lappend copy $s]; return $s} + # Some tests require the testobj command -testConstraint testobj [expr {[info commands testobj] != {}}] -testConstraint testindexobj [expr {[info commands testindexobj] != {}}] -testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}] +testConstraint testobj [expr {[info commands testobj] ne {}}] +testConstraint testindexobj [expr {[info commands testindexobj] ne {}}] +testConstraint testevalex [expr {[info commands testevalex] ne {}}] +testConstraint tip389 [expr {[string length \U010000] == 2}] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + set lines [split [memory info] \n] + return [lindex $lines 3 3] + } + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } +} + +proc representationpoke s { + set r [::tcl::unsupported::representation $s] + list [lindex $r 3] [string match {*, string representation "*"} $r] +} + +foreach noComp {0 1} { + +if {$noComp} { + if {[info commands testevalex] eq {}} { + test string-0.1.$noComp "show testevalex availability" {testevalex} {list} {} + continue + } + interp alias {} run {} testevalex + set constraints testevalex +} else { + interp alias {} run {} try + set constraints {} +} -test string-1.1 {error conditions} { - list [catch {string gorp a b} msg] $msg + +test string-1.1.$noComp {error conditions} { + list [catch {run {string gorp a b}} msg] $msg } {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} -test string-1.2 {error conditions} { - list [catch {string} msg] $msg +test string-1.2.$noComp {error conditions} { + list [catch {run {string}} msg] $msg } {1 {wrong # args: should be "string subcommand ?arg ...?"}} +test stringComp-1.3.$noComp {error condition - undefined method during compile} { + # We don't want this to complain about 'never' because it may never + # be called, or string may get redefined. This must compile OK. + proc foo {str i} { + if {"yes" == "no"} { string never called but complains here } + string index $str $i + } + foo abc 0 +} a -test string-2.1 {string compare, too few args} { - list [catch {string compare a} msg] $msg +test string-2.1.$noComp {string compare, too few args} { + list [catch {run {string compare a}} msg] $msg } {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test string-2.2 {string compare, bad args} { - list [catch {string compare a b c} msg] $msg +test string-2.2.$noComp {string compare, bad args} { + list [catch {run {string compare a b c}} msg] $msg } {1 {bad option "a": must be -nocase or -length}} -test string-2.3 {string compare, bad args} { - list [catch {string compare -length -nocase str1 str2} msg] $msg +test string-2.3.$noComp {string compare, bad args} { + list [catch {run {string compare -length -nocase str1 str2}} msg] $msg } {1 {expected integer but got "-nocase"}} -test string-2.4 {string compare, too many args} { - list [catch {string compare -length 10 -nocase str1 str2 str3} msg] $msg +test string-2.4.$noComp {string compare, too many args} { + list [catch {run {string compare -length 10 -nocase str1 str2 str3}} msg] $msg } {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test string-2.5 {string compare with length unspecified} { - list [catch {string compare -length 10 10} msg] $msg +test string-2.5.$noComp {string compare with length unspecified} { + list [catch {run {string compare -length 10 10}} msg] $msg } {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test string-2.6 {string compare} { - string compare abcde abdef +test string-2.6.$noComp {string compare} { + run {string compare abcde abdef} } -1 -test string-2.7 {string compare, shortest method name} { - string co abcde ABCDE +test string-2.7.$noComp {string compare, shortest method name} { + run {string co abcde ABCDE} } 1 -test string-2.8 {string compare} { - string compare abcde abcde +test string-2.8.$noComp {string compare} { + run {string compare abcde abcde} } 0 -test string-2.9 {string compare with length} { - string compare -length 2 abcde abxyz +test string-2.9.$noComp {string compare with length} { + run {string compare -length 2 abcde abxyz} } 0 -test string-2.10 {string compare with special index} { - list [catch {string compare -length end-3 abcde abxyz} msg] $msg +test string-2.10.$noComp {string compare with special index} { + list [catch {run {string compare -length end-3 abcde abxyz}} msg] $msg } {1 {expected integer but got "end-3"}} -test string-2.11 {string compare, unicode} { - string compare ab\u7266 ab\u7267 +test string-2.11.$noComp {string compare, unicode} { + run {string compare ab\u7266 ab\u7267} +} -1 +test string-2.11.1.$noComp {string compare, unicode} { + run {string compare \334 \u00dc} +} 0 +test string-2.11.2.$noComp {string compare, unicode} { + run {string compare \334 \u00fc} } -1 -test string-2.12 {string compare, high bit} { +test string-2.11.3.$noComp {string compare, unicode} { + run {string compare \334\334\334\374\374 \334\334\334\334\334} +} 1 +test string-2.12.$noComp {string compare, high bit} { # This test will fail if the underlying comparaison # is using signed chars instead of unsigned chars. # (like SunOS's default memcmp thus the compat/memcmp.c) - string compare "\x80" "@" + run {string compare "\x80" "@"} # Nb this tests works also in utf8 space because \x80 is # translated into a 2 or more bytelength but whose first byte has # the high bit set. } 1 -test string-2.13 {string compare -nocase} { - string compare -nocase abcde abdef +test string-2.13.$noComp {string compare -nocase} { + run {string compare -nocase abcde abdef} +} -1 +test string-2.13.1.$noComp {string compare -nocase} { + run {string compare -nocase abcde Abdef} } -1 -test string-2.14 {string compare -nocase} { - string compare -nocase abcde ABCDE +test string-2.14.$noComp {string compare -nocase} { + run {string compare -nocase abcde ABCDE} } 0 -test string-2.15 {string compare -nocase} { - string compare -nocase abcde abcde +test string-2.15.$noComp {string compare -nocase} { + run {string compare -nocase abcde abcde} } 0 -test string-2.16 {string compare -nocase with length} { - string compare -length 2 -nocase abcde Abxyz +test string-2.15.1.$noComp {string compare -nocase} { + run {string compare -nocase \334 \u00dc} } 0 -test string-2.17 {string compare -nocase with length} { - string compare -nocase -length 3 abcde Abxyz +test string-2.15.2.$noComp {string compare -nocase} { + run {string compare -nocase \334\334\334\374\u00fc \334\334\334\334\334} +} 0 +test string-2.16.$noComp {string compare -nocase with length} { + run {string compare -length 2 -nocase abcde Abxyz} +} 0 +test string-2.17.$noComp {string compare -nocase with length} { + run {string compare -nocase -length 3 abcde Abxyz} } -1 -test string-2.18 {string compare -nocase with length <= 0} { - string compare -nocase -length -1 abcde AbCdEf +test string-2.18.$noComp {string compare -nocase with length <= 0} { + run {string compare -nocase -length -1 abcde AbCdEf} } -1 -test string-2.19 {string compare -nocase with excessive length} { - string compare -nocase -length 50 AbCdEf abcde +test string-2.19.$noComp {string compare -nocase with excessive length} { + run {string compare -nocase -length 50 AbCdEf abcde} } 1 -test string-2.20 {string compare -len unicode} { +test string-2.20.$noComp {string compare -len unicode} { # These are strings that are 6 BYTELENGTH long, but the length # shouldn't make a different because there are actually 3 CHARS long - string compare -len 5 \334\334\334 \334\334\374 + run {string compare -len 5 \334\334\334 \334\334\374} } -1 -test string-2.21 {string compare -nocase with special index} { - list [catch {string compare -nocase -length end-3 Abcde abxyz} msg] $msg +test string-2.21.$noComp {string compare -nocase with special index} { + list [catch {run {string compare -nocase -length end-3 Abcde abxyz}} msg] $msg } {1 {expected integer but got "end-3"}} -test string-2.22 {string compare, null strings} { - string compare "" "" +test string-2.22.$noComp {string compare, null strings} { + run {string compare "" ""} } 0 -test string-2.23 {string compare, null strings} { - string compare "" foo +test string-2.23.$noComp {string compare, null strings} { + run {string compare "" foo} } -1 -test string-2.24 {string compare, null strings} { - string compare foo "" +test string-2.24.$noComp {string compare, null strings} { + run {string compare foo ""} } 1 -test string-2.25 {string compare -nocase, null strings} { - string compare -nocase "" "" +test string-2.25.$noComp {string compare -nocase, null strings} { + run {string compare -nocase "" ""} } 0 -test string-2.26 {string compare -nocase, null strings} { - string compare -nocase "" foo +test string-2.26.$noComp {string compare -nocase, null strings} { + run {string compare -nocase "" foo} } -1 -test string-2.27 {string compare -nocase, null strings} { - string compare -nocase foo "" +test string-2.27.$noComp {string compare -nocase, null strings} { + run {string compare -nocase foo ""} } 1 -test string-2.28 {string compare with length, unequal strings} { - string compare -length 2 abc abde +test string-2.28.$noComp {string compare with length, unequal strings} { + run {string compare -length 2 abc abde} } 0 -test string-2.29 {string compare with length, unequal strings} { - string compare -length 2 ab abde +test string-2.29.$noComp {string compare with length, unequal strings} { + run {string compare -length 2 ab abde} } 0 -test string-2.30 {string compare with NUL character vs. other ASCII} { +test string-2.30.$noComp {string compare with NUL character vs. other ASCII} { # Be careful here, since UTF-8 rep comparison with memcmp() of # these puts chars in the wrong order - string compare \x00 \x01 + run {string compare \x00 \x01} } -1 -test string-2.31 {string compare, high bit} { - proc foo {} {string compare "a\x80" "a@"} - foo +test string-2.31.$noComp {string compare, high bit} { + run {string compare "a\x80" "a@"} } 1 -test string-2.32 {string compare, high bit} { - proc foo {} {string compare "a\x00" "a\x01"} - foo +test string-2.32.$noComp {string compare, high bit} { + run {string compare "a\x00" "a\x01"} } -1 -test string-2.33 {string compare, high bit} { - proc foo {} {string compare "\x00\x00" "\x00\x01"} - foo +test string-2.33.$noComp {string compare, high bit} { + run {string compare "\x00\x00" "\x00\x01"} } -1 +test string-2.34.$noComp {string compare, binary equal} { + run {string compare [binary format a100 0] [binary format a100 0]} +} 0 +test string-2.35.$noComp {string compare, binary neq} { + run {string compare [binary format a100a 0 1] [binary format a100a 0 0]} +} 1 +test string-2.36.$noComp {string compare, binary neq unequal length} { + run {string compare [binary format a20a 0 1] [binary format a100a 0 0]} +} 1 # only need a few tests on equal, since it uses the same code as # string compare, but just modifies the return output -test string-3.1 {string equal} { - string equal abcde abdef +test string-3.1.$noComp {string equal} { + run {string equal abcde abdef} } 0 -test string-3.2 {string equal} { - string eq abcde ABCDE +test string-3.2.$noComp {string equal} { + run {string e abcde ABCDE} } 0 -test string-3.3 {string equal} { - string equal abcde abcde +test string-3.3.$noComp {string equal} { + run {string equal abcde abcde} } 1 -test string-3.4 {string equal -nocase} { - string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334 +test string-3.4.$noComp {string equal -nocase} { + run {string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334} } 1 -test string-3.5 {string equal -nocase} { - string equal -nocase abcde abdef +test string-3.5.$noComp {string equal -nocase} { + run {string equal -nocase abcde abdef} } 0 -test string-3.6 {string equal -nocase} { - string eq -nocase abcde ABCDE +test string-3.6.$noComp {string equal -nocase} { + run {string eq -nocase abcde ABCDE} } 1 -test string-3.7 {string equal -nocase} { - string equal -nocase abcde abcde +test string-3.7.$noComp {string equal -nocase} { + run {string equal -nocase abcde abcde} } 1 -test string-3.8 {string equal with length, unequal strings} { - string equal -length 2 abc abde +test string-3.8.$noComp {string equal with length, unequal strings} { + run {string equal -length 2 abc abde} } 1 +test string-3.9.$noComp {string equal, too few args} { + list [catch {run {string equal a}} msg] $msg +} {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}} +test string-3.10.$noComp {string equal, bad args} { + list [catch {run {string equal a b c}} msg] $msg +} {1 {bad option "a": must be -nocase or -length}} +test string-3.11.$noComp {string equal, bad args} { + list [catch {run {string equal -length -nocase str1 str2}} msg] $msg +} {1 {expected integer but got "-nocase"}} +test string-3.12.$noComp {string equal, too many args} { + list [catch {run {string equal -length 10 -nocase str1 str2 str3}} msg] $msg +} {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}} +test string-3.13.$noComp {string equal with length unspecified} { + list [catch {run {string equal -length 10 10}} msg] $msg +} {1 {wrong # args: should be "string equal ?-nocase? ?-length int? string1 string2"}} +test string-3.14.$noComp {string equal with length} { + run {string equal -length 2 abcde abxyz} +} 1 +test string-3.15.$noComp {string equal with special index} { + list [catch {run {string equal -length end-3 abcde abxyz}} msg] $msg +} {1 {expected integer but got "end-3"}} -test string-4.1 {string first, too few args} { - list [catch {string first a} msg] $msg +test string-3.16.$noComp {string equal, unicode} { + run {string equal ab\u7266 ab\u7267} +} 0 +test string-3.17.$noComp {string equal, unicode} { + run {string equal \334 \u00dc} +} 1 +test string-3.18.$noComp {string equal, unicode} { + run {string equal \334 \u00fc} +} 0 +test string-3.19.$noComp {string equal, unicode} { + run {string equal \334\334\334\374\374 \334\334\334\334\334} +} 0 +test string-3.20.$noComp {string equal, high bit} { + # This test will fail if the underlying comparaison + # is using signed chars instead of unsigned chars. + # (like SunOS's default memcmp thus the compat/memcmp.c) + run {string equal "\x80" "@"} + # Nb this tests works also in utf8 space because \x80 is + # translated into a 2 or more bytelength but whose first byte has + # the high bit set. +} 0 +test string-3.21.$noComp {string equal -nocase} { + run {string equal -nocase abcde Abdef} +} 0 +test string-3.22.$noComp {string equal, -nocase unicode} { + run {string equal -nocase \334 \u00dc} +} 1 +test string-3.23.$noComp {string equal, -nocase unicode} { + run {string equal -nocase \334\334\334\374\u00fc \334\334\334\334\334} +} 1 +test string-3.24.$noComp {string equal -nocase with length} { + run {string equal -length 2 -nocase abcde Abxyz} +} 1 +test string-3.25.$noComp {string equal -nocase with length} { + run {string equal -nocase -length 3 abcde Abxyz} +} 0 +test string-3.26.$noComp {string equal -nocase with length <= 0} { + run {string equal -nocase -length -1 abcde AbCdEf} +} 0 +test string-3.27.$noComp {string equal -nocase with excessive length} { + run {string equal -nocase -length 50 AbCdEf abcde} +} 0 +test string-3.28.$noComp {string equal -len unicode} { + # These are strings that are 6 BYTELENGTH long, but the length + # shouldn't make a different because there are actually 3 CHARS long + run {string equal -len 5 \334\334\334 \334\334\374} +} 0 +test string-3.29.$noComp {string equal -nocase with special index} { + list [catch {run {string equal -nocase -length end-3 Abcde abxyz}} msg] $msg +} {1 {expected integer but got "end-3"}} +test string-3.30.$noComp {string equal, null strings} { + run {string equal "" ""} +} 1 +test string-3.31.$noComp {string equal, null strings} { + run {string equal "" foo} +} 0 +test string-3.32.$noComp {string equal, null strings} { + run {string equal foo ""} +} 0 +test string-3.33.$noComp {string equal -nocase, null strings} { + run {string equal -nocase "" ""} +} 1 +test string-3.34.$noComp {string equal -nocase, null strings} { + run {string equal -nocase "" foo} +} 0 +test string-3.35.$noComp {string equal -nocase, null strings} { + run {string equal -nocase foo ""} +} 0 +test string-3.36.$noComp {string equal with NUL character vs. other ASCII} { + # Be careful here, since UTF-8 rep comparison with memcmp() of + # these puts chars in the wrong order + run {string equal \x00 \x01} +} 0 +test string-3.37.$noComp {string equal, high bit} { + run {string equal "a\x80" "a@"} +} 0 +test string-3.38.$noComp {string equal, high bit} { + run {string equal "a\x00" "a\x01"} +} 0 +test string-3.39.$noComp {string equal, high bit} { + run {string equal "a\x00\x00" "a\x00\x01"} +} 0 +test string-3.40.$noComp {string equal, binary equal} { + run {string equal [binary format a100 0] [binary format a100 0]} +} 1 +test string-3.41.$noComp {string equal, binary neq} { + run {string equal [binary format a100a 0 1] [binary format a100a 0 0]} +} 0 +test string-3.42.$noComp {string equal, binary neq inequal length} { + run {string equal [binary format a20a 0 1] [binary format a100a 0 0]} +} 0 + + +test string-4.1.$noComp {string first, too few args} { + list [catch {run {string first a}} msg] $msg } {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}} -test string-4.2 {string first, bad args} { - list [catch {string first a b c} msg] $msg +test string-4.2.$noComp {string first, bad args} { + list [catch {run {string first a b c}} msg] $msg } {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} -test string-4.3 {string first, too many args} { - list [catch {string first a b 5 d} msg] $msg +test string-4.3.$noComp {string first, too many args} { + list [catch {run {string first a b 5 d}} msg] $msg } {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}} -test string-4.4 {string first} { - string first bq abcdefgbcefgbqrs +test string-4.4.$noComp {string first} { + run {string first bq abcdefgbcefgbqrs} } 12 -test string-4.5 {string first} { - string fir bcd abcdefgbcefgbqrs +test string-4.5.$noComp {string first} { + run {string fir bcd abcdefgbcefgbqrs} } 1 -test string-4.6 {string first} { - string f b abcdefgbcefgbqrs +test string-4.6.$noComp {string first} { + run {string f b abcdefgbcefgbqrs} } 1 -test string-4.7 {string first} { - string first xxx x123xx345xxx789xxx012 +test string-4.7.$noComp {string first} { + run {string first xxx x123xx345xxx789xxx012} } 9 -test string-4.8 {string first} { - string first "" x123xx345xxx789xxx012 +test string-4.8.$noComp {string first} { + run {string first "" x123xx345xxx789xxx012} } -1 -test string-4.9 {string first, unicode} { - string first x abc\u7266x +test string-4.9.$noComp {string first, unicode} { + run {string first x abc\u7266x} } 4 -test string-4.10 {string first, unicode} { - string first \u7266 abc\u7266x +test string-4.10.$noComp {string first, unicode} { + run {string first \u7266 abc\u7266x} } 3 -test string-4.11 {string first, start index} { - string first \u7266 abc\u7266x 3 +test string-4.11.$noComp {string first, start index} { + run {string first \u7266 abc\u7266x 3} } 3 -test string-4.12 {string first, start index} { - string first \u7266 abc\u7266x 4 +test string-4.12.$noComp {string first, start index} { + run {string first \u7266 abc\u7266x 4} } -1 -test string-4.13 {string first, start index} { - string first \u7266 abc\u7266x end-2 +test string-4.13.$noComp {string first, start index} { + run {string first \u7266 abc\u7266x end-2} } 3 -test string-4.14 {string first, negative start index} { - string first b abc -1 +test string-4.14.$noComp {string first, negative start index} { + run {string first b abc -1} } 1 -test string-4.15 {string first, ability to two-byte encoded utf-8 chars} { +test string-4.15.$noComp {string first, ability to two-byte encoded utf-8 chars} { # Test for a bug in Tcl 8.3 where test for all-single-byte-encoded # strings was incorrect, leading to an index returned by [string first] # which pointed past the end of the string. set uchar \u057e ;# character with two-byte encoding in utf-8 - string first % %#$uchar$uchar#$uchar$uchar#% 3 + run {string first % %#$uchar$uchar#$uchar$uchar#% 3} } 8 +test string-4.16.$noComp {string first, normal string vs pure unicode string} { + set s hello + regexp ll $s m + # Representation checks are canaries + run {list [representationpoke $s] [representationpoke $m] \ + [string first $m $s]} +} {{string 1} {string 0} 2} -test string-5.1 {string index} { - list [catch {string index} msg] $msg +test string-5.1.$noComp {string index} { + list [catch {run {string index}} msg] $msg } {1 {wrong # args: should be "string index string charIndex"}} -test string-5.2 {string index} { - list [catch {string index a b c} msg] $msg +test string-5.2.$noComp {string index} { + list [catch {run {string index a b c}} msg] $msg } {1 {wrong # args: should be "string index string charIndex"}} -test string-5.3 {string index} { - string index abcde 0 +test string-5.3.$noComp {string index} { + run {string index abcde 0} } a -test string-5.4 {string index} { - string in abcde 4 +test string-5.4.$noComp {string index} { + run {string ind abcde 4} } e -test string-5.5 {string index} { - string index abcde 5 +test string-5.5.$noComp {string index} { + run {string index abcde 5} } {} -test string-5.6 {string index} { - list [catch {string index abcde -10} msg] $msg +test string-5.6.$noComp {string index} { + list [catch {run {string index abcde -10}} msg] $msg } {0 {}} -test string-5.7 {string index} { - list [catch {string index a xyz} msg] $msg +test string-5.7.$noComp {string index} { + list [catch {run {string index a xyz}} msg] $msg } {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}} -test string-5.8 {string index} { - string index abc end +test string-5.8.$noComp {string index} { + run {string index abc end} } c -test string-5.9 {string index} { - string index abc end-1 +test string-5.9.$noComp {string index} { + run {string index abc end-1} } b -test string-5.10 {string index, unicode} { - string index abc\u7266d 4 +test string-5.10.$noComp {string index, unicode} { + run {string index abc\u7266d 4} } d -test string-5.11 {string index, unicode} { - string index abc\u7266d 3 +test string-5.11.$noComp {string index, unicode} { + run {string index abc\u7266d 3} } \u7266 -test string-5.12 {string index, unicode over char length, under byte length} { - string index \334\374\334\374 6 +test string-5.12.$noComp {string index, unicode over char length, under byte length} { + run {string index \334\374\334\374 6} } {} -test string-5.13 {string index, bytearray object} { - string index [binary format a5 fuz] 0 +test string-5.13.$noComp {string index, bytearray object} { + run {string index [binary format a5 fuz] 0} } f -test string-5.14 {string index, bytearray object} { - string index [binary format I* {0x50515253 0x52}] 3 +test string-5.14.$noComp {string index, bytearray object} { + run {string index [binary format I* {0x50515253 0x52}] 3} } S -test string-5.15 {string index, bytearray object} { +test string-5.15.$noComp {string index, bytearray object} { set b [binary format I* {0x50515253 0x52}] - set i1 [string index $b end-6] - set i2 [string index $b 1] - string compare $i1 $i2 + set i1 [run {string index $b end-6}] + set i2 [run {string index $b 1}] + run {string compare $i1 $i2} } 0 -test string-5.16 {string index, bytearray object with string obj shimmering} { +test string-5.16.$noComp {string index, bytearray object with string obj shimmering} { set str "0123456789\x00 abcdedfghi" binary scan $str H* dump - string compare [string index $str 10] \x00 + run {string compare [run {string index $str 10}] \x00} } 0 -test string-5.17 {string index, bad integer} -body { - list [catch {string index "abc" 0o8} msg] $msg +test string-5.17.$noComp {string index, bad integer} -body { + list [catch {run {string index "abc" 0o8}} msg] $msg } -match glob -result {1 {*invalid octal number*}} -test string-5.18 {string index, bad integer} -body { - list [catch {string index "abc" end-0o0289} msg] $msg +test string-5.18.$noComp {string index, bad integer} -body { + list [catch {run {string index "abc" end-0o0289}} msg] $msg } -match glob -result {1 {*invalid octal number*}} -test string-5.19 {string index, bytearray object out of bounds} { - string index [binary format I* {0x50515253 0x52}] -1 +test string-5.19.$noComp {string index, bytearray object out of bounds} { + run {string index [binary format I* {0x50515253 0x52}] -1} } {} -test string-5.20 {string index, bytearray object out of bounds} { - string index [binary format I* {0x50515253 0x52}] 20 +test string-5.20.$noComp {string index, bytearray object out of bounds} { + run {string index [binary format I* {0x50515253 0x52}] 20} } {} +test string-5.21.$noComp {string index, surrogates, bug [11ae2be95dac9417]} tip389 { + run {list [string index a\U100000b 1] [string index a\U100000b 2] [string index a\U100000b 3]} +} [list \U100000 {} b] proc largest_int {} { @@ -302,871 +501,871 @@ proc largest_int {} { return [expr {$int-1}] } -test string-6.1 {string is, too few args} { - list [catch {string is} msg] $msg +test string-6.1.$noComp {string is, too few args} { + list [catch {run {string is}} msg] $msg } {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} -test string-6.2 {string is, too few args} { - list [catch {string is alpha} msg] $msg +test string-6.2.$noComp {string is, too few args} { + list [catch {run {string is alpha}} msg] $msg } {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} -test string-6.3 {string is, bad args} { - list [catch {string is alpha -failin str} msg] $msg +test string-6.3.$noComp {string is, bad args} { + list [catch {run {string is alpha -failin str}} msg] $msg } {1 {wrong # args: should be "string is alpha ?-strict? ?-failindex var? str"}} -test string-6.4 {string is, too many args} { - list [catch {string is alpha -failin var -strict str more} msg] $msg +test string-6.4.$noComp {string is, too many args} { + list [catch {run {string is alpha -failin var -strict str more}} msg] $msg } {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}} -test string-6.5 {string is, class check} { - list [catch {string is bogus str} msg] $msg +test string-6.5.$noComp {string is, class check} { + list [catch {run {string is bogus str}} msg] $msg } {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} -test string-6.6 {string is, ambiguous class} { - list [catch {string is al str} msg] $msg +test string-6.6.$noComp {string is, ambiguous class} { + list [catch {run {string is al str}} msg] $msg } {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, dict, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}} -test string-6.7 {string is alpha, all ok} { - string is alpha -strict -failindex var abc +test string-6.7.$noComp {string is alpha, all ok} { + run {string is alpha -strict -failindex var abc} } 1 -test string-6.8 {string is, error in var} { - list [string is alpha -failindex var abc5def] $var +test string-6.8.$noComp {string is, error in var} { + list [run {string is alpha -failindex var abc5def}] $var } {0 3} -test string-6.9 {string is, var shouldn't get set} { +test string-6.9.$noComp {string is, var shouldn't get set} { catch {unset var} - list [catch {string is alpha -failindex var abc; set var} msg] $msg + list [catch {run {string is alpha -failindex var abc; set var}} msg] $msg } {1 {can't read "var": no such variable}} -test string-6.10 {string is, ok on empty} { - string is alpha {} +test string-6.10.$noComp {string is, ok on empty} { + run {string is alpha {}} } 1 -test string-6.11 {string is, -strict check against empty} { - string is alpha -strict {} +test string-6.11.$noComp {string is, -strict check against empty} { + run {string is alpha -strict {}} } 0 -test string-6.12 {string is alnum, true} { - string is alnum abc123 +test string-6.12.$noComp {string is alnum, true} { + run {string is alnum abc123} } 1 -test string-6.13 {string is alnum, false} { - list [string is alnum -failindex var abc1.23] $var +test string-6.13.$noComp {string is alnum, false} { + list [run {string is alnum -failindex var abc1.23}] $var } {0 4} -test string-6.14 {string is alnum, unicode} "string is alnum abc\xfc" 1 -test string-6.15 {string is alpha, true} { - string is alpha abc +test string-6.14.$noComp {string is alnum, unicode} "run {string is alnum abc\xfc}" 1 +test string-6.15.$noComp {string is alpha, true} { + run {string is alpha abc} } 1 -test string-6.16 {string is alpha, false} { - list [string is alpha -fail var a1bcde] $var +test string-6.16.$noComp {string is alpha, false} { + list [run {string is alpha -fail var a1bcde}] $var } {0 1} -test string-6.17 {string is alpha, unicode} { - string is alpha abc\374 +test string-6.17.$noComp {string is alpha, unicode} { + run {string is alpha abc\374} } 1 -test string-6.18 {string is ascii, true} { - string is ascii abc\u007Fend\u0000 +test string-6.18.$noComp {string is ascii, true} { + run {string is ascii abc\u007Fend\u0000} } 1 -test string-6.19 {string is ascii, false} { - list [string is ascii -fail var abc\u0000def\u0080more] $var +test string-6.19.$noComp {string is ascii, false} { + list [run {string is ascii -fail var abc\u0000def\u0080more}] $var } {0 7} -test string-6.20 {string is boolean, true} { - string is boolean true +test string-6.20.$noComp {string is boolean, true} { + run {string is boolean true} } 1 -test string-6.21 {string is boolean, true} { - string is boolean f +test string-6.21.$noComp {string is boolean, true} { + run {string is boolean f} } 1 -test string-6.22 {string is boolean, true based on type} { - string is bool [string compare a a] +test string-6.22.$noComp {string is boolean, true based on type} { + run {string is bool [run {string compare a a}]} } 1 -test string-6.23 {string is boolean, false} { - list [string is bool -fail var yada] $var +test string-6.23.$noComp {string is boolean, false} { + list [run {string is bool -fail var yada}] $var } {0 0} -test string-6.24 {string is digit, true} { - string is digit 0123456789 +test string-6.24.$noComp {string is digit, true} { + run {string is digit 0123456789} } 1 -test string-6.25 {string is digit, false} { - list [string is digit -fail var 0123\u00dc567] $var +test string-6.25.$noComp {string is digit, false} { + list [run {string is digit -fail var 0123\u00dc567}] $var } {0 4} -test string-6.26 {string is digit, false} { - list [string is digit -fail var +123567] $var +test string-6.26.$noComp {string is digit, false} { + list [run {string is digit -fail var +123567}] $var } {0 0} -test string-6.27 {string is double, true} { - string is double 1 +test string-6.27.$noComp {string is double, true} { + run {string is double 1} } 1 -test string-6.28 {string is double, true} { - string is double [expr double(1)] +test string-6.28.$noComp {string is double, true} { + run {string is double [expr double(1)]} } 1 -test string-6.29 {string is double, true} { - string is double 1.0 +test string-6.29.$noComp {string is double, true} { + run {string is double 1.0} } 1 -test string-6.30 {string is double, true} { - string is double [string compare a a] +test string-6.30.$noComp {string is double, true} { + run {string is double [run {string compare a a}]} } 1 -test string-6.31 {string is double, true} { - string is double " +1.0e-1 " +test string-6.31.$noComp {string is double, true} { + run {string is double " +1.0e-1 "} } 1 -test string-6.32 {string is double, true} { - string is double "\n1.0\v" +test string-6.32.$noComp {string is double, true} { + run {string is double "\n1.0\v"} } 1 -test string-6.33 {string is double, false} { - list [string is double -fail var 1abc] $var +test string-6.33.$noComp {string is double, false} { + list [run {string is double -fail var 1abc}] $var } {0 1} -test string-6.34 {string is double, false} { - list [string is double -fail var abc] $var +test string-6.34.$noComp {string is double, false} { + list [run {string is double -fail var abc}] $var } {0 0} -test string-6.35 {string is double, false} { - list [string is double -fail var " 1.0e4e4 "] $var +test string-6.35.$noComp {string is double, false} { + list [run {string is double -fail var " 1.0e4e4 "}] $var } {0 8} -test string-6.36 {string is double, false} { - list [string is double -fail var "\n"] $var +test string-6.36.$noComp {string is double, false} { + list [run {string is double -fail var "\n"}] $var } {0 0} -test string-6.37 {string is double, false on int overflow} -setup { +test string-6.37.$noComp {string is double, false on int overflow} -setup { set var priorValue } -body { # Make it the largest int recognizable, with one more digit for overflow # Since bignums arrived in Tcl 8.5, the sense of this test changed. # Now integer values that exceed native limits become bignums, and # bignums can convert to doubles without error. - list [string is double -fail var [largest_int]0] $var + list [run {string is double -fail var [largest_int]0}] $var } -result {1 priorValue} # string-6.38 removed, underflow on input is no longer an error. -test string-6.39 {string is double, false} { +test string-6.39.$noComp {string is double, false} { # This test is non-portable because IRIX thinks # that .e1 is a valid double - this is really a bug # on IRIX as .e1 should NOT be a valid double # # Portable now. Tcl 8.5 does its own double parsing. - list [string is double -fail var .e1] $var + list [run {string is double -fail var .e1}] $var } {0 0} -test string-6.40 {string is false, true} { - string is false false +test string-6.40.$noComp {string is false, true} { + run {string is false false} } 1 -test string-6.41 {string is false, true} { - string is false FaLsE +test string-6.41.$noComp {string is false, true} { + run {string is false FaLsE} } 1 -test string-6.42 {string is false, true} { - string is false N +test string-6.42.$noComp {string is false, true} { + run {string is false N} } 1 -test string-6.43 {string is false, true} { - string is false 0 +test string-6.43.$noComp {string is false, true} { + run {string is false 0} } 1 -test string-6.44 {string is false, true} { - string is false off +test string-6.44.$noComp {string is false, true} { + run {string is false off} } 1 -test string-6.45 {string is false, false} { - list [string is false -fail var abc] $var +test string-6.45.$noComp {string is false, false} { + list [run {string is false -fail var abc}] $var } {0 0} -test string-6.46 {string is false, false} { +test string-6.46.$noComp {string is false, false} { catch {unset var} - list [string is false -fail var Y] $var + list [run {string is false -fail var Y}] $var } {0 0} -test string-6.47 {string is false, false} { +test string-6.47.$noComp {string is false, false} { catch {unset var} - list [string is false -fail var offensive] $var + list [run {string is false -fail var offensive}] $var } {0 0} -test string-6.48 {string is integer, true} { - string is integer +1234567890 +test string-6.48.$noComp {string is integer, true} { + run {string is integer +1234567890} } 1 -test string-6.49 {string is integer, true on type} { - string is integer [expr int(50.0)] +test string-6.49.$noComp {string is integer, true on type} { + run {string is integer [expr int(50.0)]} } 1 -test string-6.50 {string is integer, true} { - string is integer [list -10] +test string-6.50.$noComp {string is integer, true} { + run {string is integer [list -10]} } 1 -test string-6.51 {string is integer, true as hex} { - string is integer 0xabcdef +test string-6.51.$noComp {string is integer, true as hex} { + run {string is integer 0xabcdef} } 1 -test string-6.52 {string is integer, true as octal} { - string is integer 012345 +test string-6.52.$noComp {string is integer, true as octal} { + run {string is integer 012345} } 1 -test string-6.53 {string is integer, true with whitespace} { - string is integer " \n1234\v" +test string-6.53.$noComp {string is integer, true with whitespace} { + run {string is integer " \n1234\v"} } 1 -test string-6.54 {string is integer, false} { - list [string is integer -fail var 123abc] $var +test string-6.54.$noComp {string is integer, false} { + list [run {string is integer -fail var 123abc}] $var } {0 3} -test string-6.55 {string is integer, false on overflow} { - list [string is integer -fail var +[largest_int]0] $var -} {0 -1} -test string-6.56 {string is integer, false} { - list [string is integer -fail var [expr double(1)]] $var +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} -test string-6.57 {string is integer, false} { - list [string is integer -fail var " "] $var +test string-6.57.$noComp {string is integer, false} { + list [run {string is integer -fail var " "}] $var } {0 0} -test string-6.58 {string is integer, false on bad octal} { - list [string is integer -fail var 0o36963] $var +test string-6.58.$noComp {string is integer, false on bad octal} { + list [run {string is integer -fail var 0o36963}] $var } {0 4} -test string-6.58.1 {string is integer, false on bad octal} { - list [string is integer -fail var 0o36963] $var +test string-6.58.1.$noComp {string is integer, false on bad octal} { + list [run {string is integer -fail var 0o36963}] $var } {0 4} -test string-6.59 {string is integer, false on bad hex} { - list [string is integer -fail var 0X345XYZ] $var +test string-6.59.$noComp {string is integer, false on bad hex} { + list [run {string is integer -fail var 0X345XYZ}] $var } {0 5} -test string-6.60 {string is lower, true} { - string is lower abc +test string-6.60.$noComp {string is lower, true} { + run {string is lower abc} } 1 -test string-6.61 {string is lower, unicode true} { - string is lower abc\u00fcue +test string-6.61.$noComp {string is lower, unicode true} { + run {string is lower abc\u00fcue} } 1 -test string-6.62 {string is lower, false} { - list [string is lower -fail var aBc] $var +test string-6.62.$noComp {string is lower, false} { + list [run {string is lower -fail var aBc}] $var } {0 1} -test string-6.63 {string is lower, false} { - list [string is lower -fail var abc1] $var +test string-6.63.$noComp {string is lower, false} { + list [run {string is lower -fail var abc1}] $var } {0 3} -test string-6.64 {string is lower, unicode false} { - list [string is lower -fail var ab\u00dcUE] $var +test string-6.64.$noComp {string is lower, unicode false} { + list [run {string is lower -fail var ab\u00dcUE}] $var } {0 2} -test string-6.65 {string is space, true} { - string is space " \t\n\v\f" +test string-6.65.$noComp {string is space, true} { + run {string is space " \t\n\v\f"} } 1 -test string-6.66 {string is space, false} { - list [string is space -fail var " \t\n\v1\f"] $var +test string-6.66.$noComp {string is space, false} { + list [run {string is space -fail var " \t\n\v1\f"}] $var } {0 4} -test string-6.67 {string is true, true} { - string is true true +test string-6.67.$noComp {string is true, true} { + run {string is true true} } 1 -test string-6.68 {string is true, true} { - string is true TrU +test string-6.68.$noComp {string is true, true} { + run {string is true TrU} } 1 -test string-6.69 {string is true, true} { - string is true ye +test string-6.69.$noComp {string is true, true} { + run {string is true ye} } 1 -test string-6.70 {string is true, true} { - string is true 1 +test string-6.70.$noComp {string is true, true} { + run {string is true 1} } 1 -test string-6.71 {string is true, true} { - string is true on +test string-6.71.$noComp {string is true, true} { + run {string is true on} } 1 -test string-6.72 {string is true, false} { - list [string is true -fail var onto] $var +test string-6.72.$noComp {string is true, false} { + list [run {string is true -fail var onto}] $var } {0 0} -test string-6.73 {string is true, false} { +test string-6.73.$noComp {string is true, false} { catch {unset var} - list [string is true -fail var 25] $var + list [run {string is true -fail var 25}] $var } {0 0} -test string-6.74 {string is true, false} { +test string-6.74.$noComp {string is true, false} { catch {unset var} - list [string is true -fail var no] $var + list [run {string is true -fail var no}] $var } {0 0} -test string-6.75 {string is upper, true} { - string is upper ABC +test string-6.75.$noComp {string is upper, true} { + run {string is upper ABC} } 1 -test string-6.76 {string is upper, unicode true} { - string is upper ABC\u00dcUE +test string-6.76.$noComp {string is upper, unicode true} { + run {string is upper ABC\u00dcUE} } 1 -test string-6.77 {string is upper, false} { - list [string is upper -fail var AbC] $var +test string-6.77.$noComp {string is upper, false} { + list [run {string is upper -fail var AbC}] $var } {0 1} -test string-6.78 {string is upper, false} { - list [string is upper -fail var AB2C] $var +test string-6.78.$noComp {string is upper, false} { + list [run {string is upper -fail var AB2C}] $var } {0 2} -test string-6.79 {string is upper, unicode false} { - list [string is upper -fail var ABC\u00fcue] $var +test string-6.79.$noComp {string is upper, unicode false} { + list [run {string is upper -fail var ABC\u00fcue}] $var } {0 3} -test string-6.80 {string is wordchar, true} { - string is wordchar abc_123 +test string-6.80.$noComp {string is wordchar, true} { + run {string is wordchar abc_123} } 1 -test string-6.81 {string is wordchar, unicode true} { - string is wordchar abc\u00fcab\u00dcAB\u5001 +test string-6.81.$noComp {string is wordchar, unicode true} { + run {string is wordchar abc\u00fcab\u00dcAB\u5001} } 1 -test string-6.82 {string is wordchar, false} { - list [string is wordchar -fail var abcd.ef] $var +test string-6.82.$noComp {string is wordchar, false} { + list [run {string is wordchar -fail var abcd.ef}] $var } {0 4} -test string-6.83 {string is wordchar, unicode false} { - list [string is wordchar -fail var abc\u0080def] $var +test string-6.83.$noComp {string is wordchar, unicode false} { + list [run {string is wordchar -fail var abc\u0080def}] $var } {0 3} -test string-6.84 {string is control} { +test string-6.84.$noComp {string is control} { ## Control chars are in the ranges ## 00..1F && 7F..9F - list [string is control -fail var \x00\x01\x10\x1F\x7F\x80\x9F\x60] $var + list [run {string is control -fail var \x00\x01\x10\x1F\x7F\x80\x9F\x60}] $var } {0 7} -test string-6.85 {string is control} { - string is control \u0100 +test string-6.85.$noComp {string is control} { + run {string is control \u0100} } 0 -test string-6.86 {string is graph} { +test string-6.86.$noComp {string is graph} { ## graph is any print char, except space - list [string is gra -fail var "0123abc!@#\$\u0100\UE0100\UE01EF "] $var + list [run {string is gra -fail var "0123abc!@#\$\u0100\UE0100\UE01EF "}] $var } {0 14} -test string-6.87 {string is print} { +test string-6.87.$noComp {string is print} { ## basically any printable char - list [string is print -fail var "0123abc!@#\$\u0100 \UE0100\UE01EF\u0010"] $var + list [run {string is print -fail var "0123abc!@#\$\u0100 \UE0100\UE01EF\u0010"}] $var } {0 15} -test string-6.88 {string is punct} { +test string-6.88.$noComp {string is punct} { ## any graph char that isn't alnum - list [string is punct -fail var "_!@#\u00beq0"] $var + list [run {string is punct -fail var "_!@#\u00beq0"}] $var } {0 4} -test string-6.89 {string is xdigit} { - list [string is xdigit -fail var 0123456789\u0061bcdefABCDEFg] $var +test string-6.89.$noComp {string is xdigit} { + list [run {string is xdigit -fail var 0123456789\u0061bcdefABCDEFg}] $var } {0 22} -test string-6.90 {string is integer, bad integers} { +test string-6.90.$noComp {string is integer, bad integers} { # SF bug #634856 set result "" set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"] foreach num $numbers { - lappend result [string is int -strict $num] + lappend result [run {string is int -strict $num}] } return $result } {1 1 0 0 0 1 0 0} -test string-6.91 {string is double, bad doubles} { +test string-6.91.$noComp {string is double, bad doubles} { set result "" set numbers [list 1.0 +1.0 ++1.0 +-1.0 -+1.0 -1.0 --1.0 "- +1.0"] foreach num $numbers { - lappend result [string is double -strict $num] + lappend result [run {string is double -strict $num}] } return $result } {1 1 0 0 0 1 0 0} -test string-6.92 {string is integer, 32-bit overflow} { +test string-6.92.$noComp {string is integer, no 64-bit overflow} { # Bug 718878 - set x 0x100000000 - list [string is integer -failindex var $x] $var -} {0 -1} -test string-6.93 {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 [string is integer -failindex var $x] $var -} {0 -1} -test string-6.94 {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 [string is integer -failindex var [expr {$x}]] $var -} {0 -1} -test string-6.95 {string is wideinteger, true} { - string is wideinteger +1234567890 + 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 -test string-6.96 {string is wideinteger, true on type} { - string is wideinteger [expr wide(50.0)] +test string-6.96.$noComp {string is wideinteger, true on type} { + run {string is wideinteger [expr wide(50.0)]} } 1 -test string-6.97 {string is wideinteger, true} { - string is wideinteger [list -10] +test string-6.97.$noComp {string is wideinteger, true} { + run {string is wideinteger [list -10]} } 1 -test string-6.98 {string is wideinteger, true as hex} { - string is wideinteger 0xabcdef +test string-6.98.$noComp {string is wideinteger, true as hex} { + run {string is wideinteger 0xabcdef} } 1 -test string-6.99 {string is wideinteger, true as octal} { - string is wideinteger 0123456 +test string-6.99.$noComp {string is wideinteger, true as octal} { + run {string is wideinteger 0123456} } 1 -test string-6.100 {string is wideinteger, true with whitespace} { - string is wideinteger " \n1234\v" +test string-6.100.$noComp {string is wideinteger, true with whitespace} { + run {string is wideinteger " \n1234\v"} } 1 -test string-6.101 {string is wideinteger, false} { - list [string is wideinteger -fail var 123abc] $var +test string-6.101.$noComp {string is wideinteger, false} { + list [run {string is wideinteger -fail var 123abc}] $var } {0 3} -test string-6.102 {string is wideinteger, false on overflow} { - list [string is wideinteger -fail var +[largest_int]0] $var +test string-6.102.$noComp {string is wideinteger, false on overflow} { + list [run {string is wideinteger -fail var +[largest_int]0}] $var } {0 -1} -test string-6.103 {string is wideinteger, false} { - list [string is wideinteger -fail var [expr double(1)]] $var +test string-6.103.$noComp {string is wideinteger, false} { + list [run {string is wideinteger -fail var [expr double(1)]}] $var } {0 1} -test string-6.104 {string is wideinteger, false} { - list [string is wideinteger -fail var " "] $var +test string-6.104.$noComp {string is wideinteger, false} { + list [run {string is wideinteger -fail var " "}] $var } {0 0} -test string-6.105 {string is wideinteger, false on bad octal} { - list [string is wideinteger -fail var 0o36963] $var +test string-6.105.$noComp {string is wideinteger, false on bad octal} { + list [run {string is wideinteger -fail var 0o36963}] $var } {0 4} -test string-6.105.1 {string is wideinteger, false on bad octal} { - list [string is wideinteger -fail var 0o36963] $var +test string-6.105.1.$noComp {string is wideinteger, false on bad octal} { + list [run {string is wideinteger -fail var 0o36963}] $var } {0 4} -test string-6.106 {string is wideinteger, false on bad hex} { - list [string is wideinteger -fail var 0X345XYZ] $var +test string-6.106.$noComp {string is wideinteger, false on bad hex} { + list [run {string is wideinteger -fail var 0X345XYZ}] $var } {0 5} -test string-6.107 {string is integer, bad integers} { +test string-6.107.$noComp {string is integer, bad integers} { # SF bug #634856 set result "" set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"] foreach num $numbers { - lappend result [string is wideinteger -strict $num] + lappend result [run {string is wideinteger -strict $num}] } return $result } {1 1 0 0 0 1 0 0} -test string-6.108 {string is double, Bug 1382287} { +test string-6.108.$noComp {string is double, Bug 1382287} { set x 2turtledoves - string is double $x - string is double $x + run {string is double $x} + run {string is double $x} } 0 -test string-6.109 {string is double, Bug 1360532} { - string is double 1\u00a0 +test string-6.109.$noComp {string is double, Bug 1360532} { + run {string is double 1\u00a0} } 0 -test string-6.110 {string is entier, true} { - string is entier +1234567890 +test string-6.110.$noComp {string is entier, true} { + run {string is entier +1234567890} } 1 -test string-6.111 {string is entier, true on type} { - string is entier [expr wide(50.0)] +test string-6.111.$noComp {string is entier, true on type} { + run {string is entier [expr wide(50.0)]} } 1 -test string-6.112 {string is entier, true} { - string is entier [list -10] +test string-6.112.$noComp {string is entier, true} { + run {string is entier [list -10]} } 1 -test string-6.113 {string is entier, true as hex} { - string is entier 0xabcdef +test string-6.113.$noComp {string is entier, true as hex} { + run {string is entier 0xabcdef} } 1 -test string-6.114 {string is entier, true as octal} { - string is entier 0123456 +test string-6.114.$noComp {string is entier, true as octal} { + run {string is entier 0123456} } 1 -test string-6.115 {string is entier, true with whitespace} { - string is entier " \n1234\v" +test string-6.115.$noComp {string is entier, true with whitespace} { + run {string is entier " \n1234\v"} } 1 -test string-6.116 {string is entier, false} { - list [string is entier -fail var 123abc] $var +test string-6.116.$noComp {string is entier, false} { + list [run {string is entier -fail var 123abc}] $var } {0 3} -test string-6.117 {string is entier, false} { - list [string is entier -fail var 123123123123123123123123123123123123123123123123123123123123123123123123123123123123abc] $var +test string-6.117.$noComp {string is entier, false} { + list [run {string is entier -fail var 123123123123123123123123123123123123123123123123123123123123123123123123123123123123abc}] $var } {0 84} -test string-6.118 {string is entier, false} { - list [string is entier -fail var [expr double(1)]] $var +test string-6.118.$noComp {string is entier, false} { + list [run {string is entier -fail var [expr double(1)]}] $var } {0 1} -test string-6.119 {string is entier, false} { - list [string is entier -fail var " "] $var +test string-6.119.$noComp {string is entier, false} { + list [run {string is entier -fail var " "}] $var } {0 0} -test string-6.120 {string is entier, false on bad octal} { - list [string is entier -fail var 0o36963] $var +test string-6.120.$noComp {string is entier, false on bad octal} { + list [run {string is entier -fail var 0o36963}] $var } {0 4} -test string-6.121.1 {string is entier, false on bad octal} { - list [string is entier -fail var 0o36963] $var +test string-6.121.1.$noComp {string is entier, false on bad octal} { + list [run {string is entier -fail var 0o36963}] $var } {0 4} -test string-6.122 {string is entier, false on bad hex} { - list [string is entier -fail var 0X345XYZ] $var +test string-6.122.$noComp {string is entier, false on bad hex} { + list [run {string is entier -fail var 0X345XYZ}] $var } {0 5} -test string-6.123 {string is entier, bad integers} { +test string-6.123.$noComp {string is entier, bad integers} { # SF bug #634856 set result "" set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"] foreach num $numbers { - lappend result [string is entier -strict $num] + lappend result [run {string is entier -strict $num}] } return $result } {1 1 0 0 0 1 0 0} -test string-6.124 {string is entier, true} { - string is entier +1234567890123456789012345678901234567890 +test string-6.124.$noComp {string is entier, true} { + run {string is entier +1234567890123456789012345678901234567890} } 1 -test string-6.125 {string is entier, true} { - string is entier [list -10000000000000000000000000000000000000000000000000000000000000000000000000000000000000] +test string-6.125.$noComp {string is entier, true} { + run {string is entier [list -10000000000000000000000000000000000000000000000000000000000000000000000000000000000000]} } 1 -test string-6.126 {string is entier, true as hex} { - string is entier 0xabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdef +test string-6.126.$noComp {string is entier, true as hex} { + run {string is entier 0xabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdef} } 1 -test string-6.127 {string is entier, true as octal} { - string is entier 0123456112341234561234565623456123456123456123456123456123456123456123456123456123456 +test string-6.127.$noComp {string is entier, true as octal} { + run {string is entier 0123456112341234561234565623456123456123456123456123456123456123456123456123456123456} } 1 -test string-6.128 {string is entier, true with whitespace} { - string is entier " \n12340000000000000000000000000000000000000000000000000000000000000000000000000000000000000\v" +test string-6.128.$noComp {string is entier, true with whitespace} { + run {string is entier " \n12340000000000000000000000000000000000000000000000000000000000000000000000000000000000000\v"} } 1 -test string-6.129 {string is entier, false on bad octal} { - list [string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963] $var +test string-6.129.$noComp {string is entier, false on bad octal} { + list [run {string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963}] $var } {0 87} -test string-6.130.1 {string is entier, false on bad octal} { - list [string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963] $var +test string-6.130.1.$noComp {string is entier, false on bad octal} { + list [run {string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963}] $var } {0 87} -test string-6.131 {string is entier, false on bad hex} { - list [string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ] $var +test string-6.131.$noComp {string is entier, false on bad hex} { + list [run {string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ}] $var } {0 88} catch {rename largest_int {}} -test string-7.1 {string last, too few args} { - list [catch {string last a} msg] $msg -} {1 {wrong # args: should be "string last needleString haystackString ?startIndex?"}} -test string-7.2 {string last, bad args} { - list [catch {string last a b c} msg] $msg +test string-7.1.$noComp {string last, too few args} { + list [catch {run {string last a}} msg] $msg +} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}} +test string-7.2.$noComp {string last, bad args} { + list [catch {run {string last a b c}} msg] $msg } {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} -test string-7.3 {string last, too many args} { - list [catch {string last a b c d} msg] $msg -} {1 {wrong # args: should be "string last needleString haystackString ?startIndex?"}} -test string-7.4 {string last} { - string la xxx xxxx123xx345x678 -} 1 -test string-7.5 {string last} { - string last xx xxxx123xx345x678 +test string-7.3.$noComp {string last, too many args} { + list [catch {run {string last a b c d}} msg] $msg +} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}} +test string-7.4.$noComp {string last} { + run {string la xxx xxxx123xx345x678} +} 1 +test string-7.5.$noComp {string last} { + run {string last xx xxxx123xx345x678} } 7 -test string-7.6 {string last} { - string las x xxxx123xx345x678 +test string-7.6.$noComp {string last} { + run {string las x xxxx123xx345x678} } 12 -test string-7.7 {string last, unicode} { - string las x xxxx12\u7266xx345x678 +test string-7.7.$noComp {string last, unicode} { + run {string las x xxxx12\u7266xx345x678} } 12 -test string-7.8 {string last, unicode} { - string las \u7266 xxxx12\u7266xx345x678 +test string-7.8.$noComp {string last, unicode} { + run {string las \u7266 xxxx12\u7266xx345x678} } 6 -test string-7.9 {string last, stop index} { - string las \u7266 xxxx12\u7266xx345x678 +test string-7.9.$noComp {string last, stop index} { + run {string las \u7266 xxxx12\u7266xx345x678} } 6 -test string-7.10 {string last, unicode} { - string las \u7266 xxxx12\u7266xx345x678 +test string-7.10.$noComp {string last, unicode} { + run {string las \u7266 xxxx12\u7266xx345x678} } 6 -test string-7.11 {string last, start index} { - string last \u7266 abc\u7266x 3 +test string-7.11.$noComp {string last, start index} { + run {string last \u7266 abc\u7266x 3} } 3 -test string-7.12 {string last, start index} { - string last \u7266 abc\u7266x 2 +test string-7.12.$noComp {string last, start index} { + run {string last \u7266 abc\u7266x 2} } -1 -test string-7.13 {string last, start index} { +test string-7.13.$noComp {string last, start index} { ## Constrain to last 'a' should work - string last ba badbad end-1 + run {string last ba badbad end-1} } 3 -test string-7.14 {string last, start index} { +test string-7.14.$noComp {string last, start index} { ## Constrain to last 'b' should skip last 'ba' - string last ba badbad end-2 + run {string last ba badbad end-2} } 0 -test string-7.15 {string last, start index} { - string last \334a \334ad\334ad 0 +test string-7.15.$noComp {string last, start index} { + run {string last \334a \334ad\334ad 0} } -1 -test string-7.16 {string last, start index} { - string last \334a \334ad\334ad end-1 +test string-7.16.$noComp {string last, start index} { + run {string last \334a \334ad\334ad end-1} } 3 -test string-8.1 {string bytelength} { - list [catch {string bytelength} msg] $msg +test string-8.1.$noComp {string bytelength} { + list [catch {run {string bytelength}} msg] $msg } {1 {wrong # args: should be "string bytelength string"}} -test string-8.2 {string bytelength} { - list [catch {string bytelength a b} msg] $msg +test string-8.2.$noComp {string bytelength} { + list [catch {run {string bytelength a b}} msg] $msg } {1 {wrong # args: should be "string bytelength string"}} -test string-8.3 {string bytelength} { - string bytelength "\u00c7" +test string-8.3.$noComp {string bytelength} { + run {string bytelength "\u00c7"} } 2 -test string-8.4 {string bytelength} { - string b "" +test string-8.4.$noComp {string bytelength} { + run {string b ""} } 0 -test string-9.1 {string length} { - list [catch {string length} msg] $msg +test string-9.1.$noComp {string length} { + list [catch {run {string length}} msg] $msg } {1 {wrong # args: should be "string length string"}} -test string-9.2 {string length} { - list [catch {string length a b} msg] $msg +test string-9.2.$noComp {string length} { + list [catch {run {string length a b}} msg] $msg } {1 {wrong # args: should be "string length string"}} -test string-9.3 {string length} { - string length "a little string" +test string-9.3.$noComp {string length} { + run {string length "a little string"} } 15 -test string-9.4 {string length} { - string le "" +test string-9.4.$noComp {string length} { + run {string le ""} } 0 -test string-9.5 {string length, unicode} { - string le "abcd\u7266" +test string-9.5.$noComp {string length, unicode} { + run {string le "abcd\u7266"} } 5 -test string-9.6 {string length, bytearray object} { - string length [binary format a5 foo] +test string-9.6.$noComp {string length, bytearray object} { + run {string length [binary format a5 foo]} } 5 -test string-9.7 {string length, bytearray object} { - string length [binary format I* {0x50515253 0x52}] +test string-9.7.$noComp {string length, bytearray object} { + run {string length [binary format I* {0x50515253 0x52}]} } 8 -test string-10.1 {string map, too few args} { - list [catch {string map} msg] $msg +test string-10.1.$noComp {string map, too few args} { + list [catch {run {string map}} msg] $msg } {1 {wrong # args: should be "string map ?-nocase? charMap string"}} -test string-10.2 {string map, bad args} { - list [catch {string map {a b} abba oops} msg] $msg +test string-10.2.$noComp {string map, bad args} { + list [catch {run {string map {a b} abba oops}} msg] $msg } {1 {bad option "a b": must be -nocase}} -test string-10.3 {string map, too many args} { - list [catch {string map -nocase {a b} str1 str2} msg] $msg +test string-10.3.$noComp {string map, too many args} { + list [catch {run {string map -nocase {a b} str1 str2}} msg] $msg } {1 {wrong # args: should be "string map ?-nocase? charMap string"}} -test string-10.4 {string map} { - string map {a b} abba +test string-10.4.$noComp {string map} { + run {string map {a b} abba} } {bbbb} -test string-10.5 {string map} { - string map {a b} a +test string-10.5.$noComp {string map} { + run {string map {a b} a} } {b} -test string-10.6 {string map -nocase} { - string map -nocase {a b} Abba +test string-10.6.$noComp {string map -nocase} { + run {string map -nocase {a b} Abba} } {bbbb} -test string-10.7 {string map} { - string map {abc 321 ab * a A} aabcabaababcab +test string-10.7.$noComp {string map} { + run {string map {abc 321 ab * a A} aabcabaababcab} } {A321*A*321*} -test string-10.8 {string map -nocase} { - string map -nocase {aBc 321 Ab * a A} aabcabaababcab +test string-10.8.$noComp {string map -nocase} { + run {string map -nocase {aBc 321 Ab * a A} aabcabaababcab} } {A321*A*321*} -test string-10.9 {string map -nocase} { - string map -no {abc 321 Ab * a A} aAbCaBaAbAbcAb +test string-10.9.$noComp {string map -nocase} { + run {string map -no {abc 321 Ab * a A} aAbCaBaAbAbcAb} } {A321*A*321*} -test string-10.10 {string map} { - list [catch {string map {a b c} abba} msg] $msg +test string-10.10.$noComp {string map} { + list [catch {run {string map {a b c} abba}} msg] $msg } {1 {char map list unbalanced}} -test string-10.11 {string map, nulls} { - string map {\x00 NULL blah \x00nix} {qwerty} +test string-10.11.$noComp {string map, nulls} { + run {string map {\x00 NULL blah \x00nix} {qwerty}} } {qwerty} -test string-10.12 {string map, unicode} { - string map [list \374 ue UE \334] "a\374ueUE\000EU" +test string-10.12.$noComp {string map, unicode} { + run {string map [list \374 ue UE \334] "a\374ueUE\000EU"} } aueue\334\0EU -test string-10.13 {string map, -nocase unicode} { - string map -nocase [list \374 ue UE \334] "a\374ueUE\000EU" +test string-10.13.$noComp {string map, -nocase unicode} { + run {string map -nocase [list \374 ue UE \334] "a\374ueUE\000EU"} } aue\334\334\0EU -test string-10.14 {string map, -nocase null arguments} { - string map -nocase {{} abc} foo +test string-10.14.$noComp {string map, -nocase null arguments} { + run {string map -nocase {{} abc} foo} } foo -test string-10.15 {string map, one pair case} { - string map -nocase {abc 32} aAbCaBaAbAbcAb +test string-10.15.$noComp {string map, one pair case} { + run {string map -nocase {abc 32} aAbCaBaAbAbcAb} } {a32aBaAb32Ab} -test string-10.16 {string map, one pair case} { - string map -nocase {ab 4321} aAbCaBaAbAbcAb +test string-10.16.$noComp {string map, one pair case} { + run {string map -nocase {ab 4321} aAbCaBaAbAbcAb} } {a4321C4321a43214321c4321} -test string-10.17 {string map, one pair case} { - string map {Ab 4321} aAbCaBaAbAbcAb +test string-10.17.$noComp {string map, one pair case} { + run {string map {Ab 4321} aAbCaBaAbAbcAb} } {a4321CaBa43214321c4321} -test string-10.18 {string map, empty argument} { - string map -nocase {{} abc} foo +test string-10.18.$noComp {string map, empty argument} { + run {string map -nocase {{} abc} foo} } foo -test string-10.19 {string map, empty arguments} { - string map -nocase {{} abc f bar {} def} foo +test string-10.19.$noComp {string map, empty arguments} { + run {string map -nocase {{} abc f bar {} def} foo} } baroo -test string-10.20 {string map, dictionaries don't alter map ordering} { +test string-10.20.$noComp {string map, dictionaries don't alter map ordering} { set map {aa X a Y} - list [string map [dict create aa X a Y] aaa] [string map $map aaa] [dict size $map] [string map $map aaa] + list [run {string map [dict create aa X a Y] aaa}] [run {string map $map aaa}] [dict size $map] [run {string map $map aaa}] } {XY XY 2 XY} -test string-10.20.1 {string map, dictionaries don't alter map ordering} { +test string-10.20.1.$noComp {string map, dictionaries don't alter map ordering} { set map {a X b Y a Z} - list [string map [dict create a X b Y a Z] aaa] [string map $map aaa] [dict size $map] [string map $map aaa] + list [run {string map [dict create a X b Y a Z] aaa}] [run {string map $map aaa}] [dict size $map] [run {string map $map aaa}] } {ZZZ XXX 2 XXX} -test string-10.21 {string map, ABR checks} { - string map {longstring foob} long +test string-10.21.$noComp {string map, ABR checks} { + run {string map {longstring foob} long} } long -test string-10.22 {string map, ABR checks} { - string map {long foob} long +test string-10.22.$noComp {string map, ABR checks} { + run {string map {long foob} long} } foob -test string-10.23 {string map, ABR checks} { - string map {lon foob} long +test string-10.23.$noComp {string map, ABR checks} { + run {string map {lon foob} long} } foobg -test string-10.24 {string map, ABR checks} { - string map {lon foob} longlo +test string-10.24.$noComp {string map, ABR checks} { + run {string map {lon foob} longlo} } foobglo -test string-10.25 {string map, ABR checks} { - string map {lon foob} longlon +test string-10.25.$noComp {string map, ABR checks} { + run {string map {lon foob} longlon} } foobgfoob -test string-10.26 {string map, ABR checks} { - string map {longstring foob longstring bar} long +test string-10.26.$noComp {string map, ABR checks} { + run {string map {longstring foob longstring bar} long} } long -test string-10.27 {string map, ABR checks} { - string map {long foob longstring bar} long +test string-10.27.$noComp {string map, ABR checks} { + run {string map {long foob longstring bar} long} } foob -test string-10.28 {string map, ABR checks} { - string map {lon foob longstring bar} long +test string-10.28.$noComp {string map, ABR checks} { + run {string map {lon foob longstring bar} long} } foobg -test string-10.29 {string map, ABR checks} { - string map {lon foob longstring bar} longlo +test string-10.29.$noComp {string map, ABR checks} { + run {string map {lon foob longstring bar} longlo} } foobglo -test string-10.30 {string map, ABR checks} { - string map {lon foob longstring bar} longlon +test string-10.30.$noComp {string map, ABR checks} { + run {string map {lon foob longstring bar} longlon} } foobgfoob -test string-10.31 {string map, nasty sharing crash from [Bug 1018562]} { +test string-10.31.$noComp {string map, nasty sharing crash from [Bug 1018562]} { set a {a b} - string map $a $a + run {string map $a $a} } {b b} -test string-11.1 {string match, too few args} { - list [catch {string match a} msg] $msg +test string-11.1.$noComp {string match, too few args} { + list [catch {run {string match a}} msg] $msg } {1 {wrong # args: should be "string match ?-nocase? pattern string"}} -test string-11.2 {string match, too many args} { - list [catch {string match a b c d} msg] $msg +test string-11.2.$noComp {string match, too many args} { + list [catch {run {string match a b c d}} msg] $msg } {1 {wrong # args: should be "string match ?-nocase? pattern string"}} -test string-11.3 {string match} { - string match abc abc +test string-11.3.$noComp {string match} { + run {string match abc abc} } 1 -test string-11.4 {string match} { - string mat abc abd +test string-11.4.$noComp {string match} { + run {string mat abc abd} } 0 -test string-11.5 {string match} { - string match ab*c abc +test string-11.5.$noComp {string match} { + run {string match ab*c abc} } 1 -test string-11.6 {string match} { - string match ab**c abc +test string-11.6.$noComp {string match} { + run {string match ab**c abc} } 1 -test string-11.7 {string match} { - string match ab* abcdef +test string-11.7.$noComp {string match} { + run {string match ab* abcdef} } 1 -test string-11.8 {string match} { - string match *c abc +test string-11.8.$noComp {string match} { + run {string match *c abc} } 1 -test string-11.9 {string match} { - string match *3*6*9 0123456789 +test string-11.9.$noComp {string match} { + run {string match *3*6*9 0123456789} } 1 -test string-11.9.1 {string match} { - string match *3*6*89 0123456789 +test string-11.9.1.$noComp {string match} { + run {string match *3*6*89 0123456789} } 1 -test string-11.9.2 {string match} { - string match *3*456*89 0123456789 +test string-11.9.2.$noComp {string match} { + run {string match *3*456*89 0123456789} } 1 -test string-11.9.3 {string match} { - string match *3*6* 0123456789 +test string-11.9.3.$noComp {string match} { + run {string match *3*6* 0123456789} } 1 -test string-11.9.4 {string match} { - string match *3*56* 0123456789 +test string-11.9.4.$noComp {string match} { + run {string match *3*56* 0123456789} } 1 -test string-11.9.5 {string match} { - string match *3*456*** 0123456789 +test string-11.9.5.$noComp {string match} { + run {string match *3*456*** 0123456789} } 1 -test string-11.9.6 {string match} { - string match **3*456** 0123456789 +test string-11.9.6.$noComp {string match} { + run {string match **3*456** 0123456789} } 1 -test string-11.9.7 {string match} { - string match *3***456* 0123456789 +test string-11.9.7.$noComp {string match} { + run {string match *3***456* 0123456789} } 1 -test string-11.9.8 {string match} { - string match *3***\[456]* 0123456789 +test string-11.9.8.$noComp {string match} { + run {string match *3***\[456]* 0123456789} } 1 -test string-11.9.9 {string match} { - string match *3***\[4-6]* 0123456789 +test string-11.9.9.$noComp {string match} { + run {string match *3***\[4-6]* 0123456789} } 1 -test string-11.9.10 {string match} { - string match *3***\[4-6] 0123456789 +test string-11.9.10.$noComp {string match} { + run {string match *3***\[4-6] 0123456789} } 0 -test string-11.9.11 {string match} { - string match *3***\[4-6] 0123456 +test string-11.9.11.$noComp {string match} { + run {string match *3***\[4-6] 0123456} } 1 -test string-11.10 {string match} { - string match *3*6*9 01234567890 +test string-11.10.$noComp {string match} { + run {string match *3*6*9 01234567890} } 0 -test string-11.10.1 {string match} { - string match *3*6*89 01234567890 +test string-11.10.1.$noComp {string match} { + run {string match *3*6*89 01234567890} } 0 -test string-11.10.2 {string match} { - string match *3*456*89 01234567890 +test string-11.10.2.$noComp {string match} { + run {string match *3*456*89 01234567890} } 0 -test string-11.10.3 {string match} { - string match **3*456*89 01234567890 +test string-11.10.3.$noComp {string match} { + run {string match **3*456*89 01234567890} } 0 -test string-11.10.4 {string match} { - string match *3*456***89 01234567890 +test string-11.10.4.$noComp {string match} { + run {string match *3*456***89 01234567890} } 0 -test string-11.11 {string match} { - string match a?c abc +test string-11.11.$noComp {string match} { + run {string match a?c abc} } 1 -test string-11.12 {string match} { - string match a??c abc +test string-11.12.$noComp {string match} { + run {string match a??c abc} } 0 -test string-11.13 {string match} { - string match ?1??4???8? 0123456789 +test string-11.13.$noComp {string match} { + run {string match ?1??4???8? 0123456789} } 1 -test string-11.14 {string match} { - string match {[abc]bc} abc +test string-11.14.$noComp {string match} { + run {string match {[abc]bc} abc} } 1 -test string-11.15 {string match} { - string match {a[abc]c} abc +test string-11.15.$noComp {string match} { + run {string match {a[abc]c} abc} } 1 -test string-11.16 {string match} { - string match {a[xyz]c} abc +test string-11.16.$noComp {string match} { + run {string match {a[xyz]c} abc} } 0 -test string-11.17 {string match} { - string match {12[2-7]45} 12345 +test string-11.17.$noComp {string match} { + run {string match {12[2-7]45} 12345} } 1 -test string-11.18 {string match} { - string match {12[ab2-4cd]45} 12345 +test string-11.18.$noComp {string match} { + run {string match {12[ab2-4cd]45} 12345} } 1 -test string-11.19 {string match} { - string match {12[ab2-4cd]45} 12b45 +test string-11.19.$noComp {string match} { + run {string match {12[ab2-4cd]45} 12b45} } 1 -test string-11.20 {string match} { - string match {12[ab2-4cd]45} 12d45 +test string-11.20.$noComp {string match} { + run {string match {12[ab2-4cd]45} 12d45} } 1 -test string-11.21 {string match} { - string match {12[ab2-4cd]45} 12145 +test string-11.21.$noComp {string match} { + run {string match {12[ab2-4cd]45} 12145} } 0 -test string-11.22 {string match} { - string match {12[ab2-4cd]45} 12545 +test string-11.22.$noComp {string match} { + run {string match {12[ab2-4cd]45} 12545} } 0 -test string-11.23 {string match} { - string match {a\*b} a*b +test string-11.23.$noComp {string match} { + run {string match {a\*b} a*b} } 1 -test string-11.24 {string match} { - string match {a\*b} ab +test string-11.24.$noComp {string match} { + run {string match {a\*b} ab} } 0 -test string-11.25 {string match} { - string match {a\*\?\[\]\\\x} "a*?\[\]\\x" +test string-11.25.$noComp {string match} { + run {string match {a\*\?\[\]\\\x} "a*?\[\]\\x"} } 1 -test string-11.26 {string match} { - string match ** "" +test string-11.26.$noComp {string match} { + run {string match ** ""} } 1 -test string-11.27 {string match} { - string match *. "" +test string-11.27.$noComp {string match} { + run {string match *. ""} } 0 -test string-11.28 {string match} { - string match "" "" +test string-11.28.$noComp {string match} { + run {string match "" ""} } 1 -test string-11.29 {string match} { - string match \[a a +test string-11.29.$noComp {string match} { + run {string match \[a a} } 1 -test string-11.30 {string match, bad args} { - list [catch {string match - b c} msg] $msg +test string-11.30.$noComp {string match, bad args} { + list [catch {run {string match - b c}} msg] $msg } {1 {bad option "-": must be -nocase}} -test string-11.31 {string match case} { - string match a A +test string-11.31.$noComp {string match case} { + run {string match a A} } 0 -test string-11.32 {string match nocase} { - string match -n a A +test string-11.32.$noComp {string match nocase} { + run {string match -n a A} } 1 -test string-11.33 {string match nocase} { - string match -nocase a\334 A\374 +test string-11.33.$noComp {string match nocase} { + run {string match -nocase a\334 A\374} } 1 -test string-11.34 {string match nocase} { - string match -nocase a*f ABCDEf +test string-11.34.$noComp {string match nocase} { + run {string match -nocase a*f ABCDEf} } 1 -test string-11.35 {string match case, false hope} { +test string-11.35.$noComp {string match case, false hope} { # This is true because '_' lies between the A-Z and a-z ranges - string match {[A-z]} _ + run {string match {[A-z]} _} } 1 -test string-11.36 {string match nocase range} { +test string-11.36.$noComp {string match nocase range} { # This is false because although '_' lies between the A-Z and a-z ranges, # we lower case the end points before checking the ranges. - string match -nocase {[A-z]} _ + run {string match -nocase {[A-z]} _} } 0 -test string-11.37 {string match nocase} { - string match -nocase {[A-fh-Z]} g +test string-11.37.$noComp {string match nocase} { + run {string match -nocase {[A-fh-Z]} g} } 0 -test string-11.38 {string match case, reverse range} { - string match {[A-fh-Z]} g +test string-11.38.$noComp {string match case, reverse range} { + run {string match {[A-fh-Z]} g} } 1 -test string-11.39 {string match, *\ case} { - string match {*\abc} abc +test string-11.39.$noComp {string match, *\ case} { + run {string match {*\abc} abc} } 1 -test string-11.39.1 {string match, *\ case} { - string match {*ab\c} abc +test string-11.39.1.$noComp {string match, *\ case} { + run {string match {*ab\c} abc} } 1 -test string-11.39.2 {string match, *\ case} { - string match {*ab\*} ab* +test string-11.39.2.$noComp {string match, *\ case} { + run {string match {*ab\*} ab*} } 1 -test string-11.39.3 {string match, *\ case} { - string match {*ab\*} abc +test string-11.39.3.$noComp {string match, *\ case} { + run {string match {*ab\*} abc} } 0 -test string-11.39.4 {string match, *\ case} { - string match {*ab\\*} {ab\c} +test string-11.39.4.$noComp {string match, *\ case} { + run {string match {*ab\\*} {ab\c}} } 1 -test string-11.39.5 {string match, *\ case} { - string match {*ab\\*} {ab\*} +test string-11.39.5.$noComp {string match, *\ case} { + run {string match {*ab\\*} {ab\*}} } 1 -test string-11.40 {string match, *special case} { - string match {*[ab]} abc +test string-11.40.$noComp {string match, *special case} { + run {string match {*[ab]} abc} } 0 -test string-11.41 {string match, *special case} { - string match {*[ab]*} abc +test string-11.41.$noComp {string match, *special case} { + run {string match {*[ab]*} abc} } 1 -test string-11.42 {string match, *special case} { - string match "*\\" "\\" +test string-11.42.$noComp {string match, *special case} { + run {string match "*\\" "\\"} } 0 -test string-11.43 {string match, *special case} { - string match "*\\\\" "\\" +test string-11.43.$noComp {string match, *special case} { + run {string match "*\\\\" "\\"} } 1 -test string-11.44 {string match, *special case} { - string match "*???" "12345" +test string-11.44.$noComp {string match, *special case} { + run {string match "*???" "12345"} } 1 -test string-11.45 {string match, *special case} { - string match "*???" "12" +test string-11.45.$noComp {string match, *special case} { + run {string match "*???" "12"} } 0 -test string-11.46 {string match, *special case} { - string match "*\\*" "abc*" +test string-11.46.$noComp {string match, *special case} { + run {string match "*\\*" "abc*"} } 1 -test string-11.47 {string match, *special case} { - string match "*\\*" "*" +test string-11.47.$noComp {string match, *special case} { + run {string match "*\\*" "*"} } 1 -test string-11.48 {string match, *special case} { - string match "*\\*" "*abc" +test string-11.48.$noComp {string match, *special case} { + run {string match "*\\*" "*abc"} } 0 -test string-11.49 {string match, *special case} { - string match "?\\*" "a*" +test string-11.49.$noComp {string match, *special case} { + run {string match "?\\*" "a*"} } 1 -test string-11.50 {string match, *special case} { - string match "\\" "\\" +test string-11.50.$noComp {string match, *special case} { + run {string match "\\" "\\"} } 0 -test string-11.51 {string match; *, -nocase and UTF-8} { - string match -nocase [binary format I 717316707] \ - [binary format I 2028036707] +test string-11.51.$noComp {string match; *, -nocase and UTF-8} { + run {string match -nocase [binary format I 717316707] \ + [binary format I 2028036707]} } 1 -test string-11.52 {string match, null char in string} { +test string-11.52.$noComp {string match, null char in string} { set out "" set ptn "*abc*" foreach elem [list "\u0000@abc" "@abc" "\u0000@abc\u0000" "blahabcblah"] { - lappend out [string match $ptn $elem] + lappend out [run {string match $ptn $elem}] } set out } {1 1 1 1} -test string-11.53 {string match, null char in pattern} { +test string-11.53.$noComp {string match, null char in pattern} { set out "" foreach {ptn elem} [list \ "*\u0000abc\u0000" "\u0000abc\u0000" \ @@ -1175,649 +1374,711 @@ test string-11.53 {string match, null char in pattern} { "*\u0000abc\u0000" "@\u0000abc\u0000ef" \ "*\u0000abc\u0000*" "@\u0000abc\u0000ef" \ ] { - lappend out [string match $ptn $elem] + lappend out [run {string match $ptn $elem}] } set out } {1 0 1 0 1} -test string-11.54 {string match, failure} { +test string-11.54.$noComp {string match, failure} { set longString "" for {set i 0} {$i < 10} {incr i} { append longString "abcdefghijklmnopqrstuvwxy\u0000z01234567890123" } - string first $longString 123 - list [string match *cba* $longString] \ - [string match *a*l*\u0000* $longString] \ - [string match *a*l*\u0000*123 $longString] \ - [string match *a*l*\u0000*123* $longString] \ - [string match *a*l*\u0000*cba* $longString] \ - [string match *===* $longString] + run {string first $longString 123} + list [run {string match *cba* $longString}] \ + [run {string match *a*l*\u0000* $longString}] \ + [run {string match *a*l*\u0000*123 $longString}] \ + [run {string match *a*l*\u0000*123* $longString}] \ + [run {string match *a*l*\u0000*cba* $longString}] \ + [run {string match *===* $longString}] } {0 1 1 1 0 0} +test string-11.55.$noComp {string match, invalid binary optimization} { + [format string] match \u0141 [binary format c 65] +} 0 -test string-12.1 {string range} { - list [catch {string range} msg] $msg +test stringComp-12.1.0.$noComp {Bug 3588366: end-offsets before start} { + apply {s { + string range $s 0 end-5 + }} 12345 +} {} +test string-12.1.$noComp {string range} { + list [catch {run {string range}} msg] $msg } {1 {wrong # args: should be "string range string first last"}} -test string-12.2 {string range} { - list [catch {string range a 1} msg] $msg +test string-12.2.$noComp {string range} { + list [catch {run {string range a 1}} msg] $msg } {1 {wrong # args: should be "string range string first last"}} -test string-12.3 {string range} { - list [catch {string range a 1 2 3} msg] $msg +test string-12.3.$noComp {string range} { + list [catch {run {string range a 1 2 3}} msg] $msg } {1 {wrong # args: should be "string range string first last"}} -test string-12.4 {string range} { - string range abcdefghijklmnop 2 14 +test string-12.4.$noComp {string range} { + run {string range abcdefghijklmnop 2 14} } {cdefghijklmno} -test string-12.5 {string range, last > length} { - string range abcdefghijklmnop 7 1000 +test string-12.5.$noComp {string range, last > length} { + run {string range abcdefghijklmnop 7 1000} } {hijklmnop} -test string-12.6 {string range} { - string range abcdefghijklmnop 10 end +test string-12.6.$noComp {string range} { + run {string range abcdefghijklmnop 10 end} } {klmnop} -test string-12.7 {string range, last < first} { - string range abcdefghijklmnop 10 9 +test string-12.7.$noComp {string range, last < first} { + run {string range abcdefghijklmnop 10 9} } {} -test string-12.8 {string range, first < 0} { - string range abcdefghijklmnop -3 2 +test string-12.8.$noComp {string range, first < 0} { + run {string range abcdefghijklmnop -3 2} } {abc} -test string-12.9 {string range} { - string range abcdefghijklmnop -3 -2 +test string-12.9.$noComp {string range} { + run {string range abcdefghijklmnop -3 -2} } {} -test string-12.10 {string range} { - string range abcdefghijklmnop 1000 1010 +test string-12.10.$noComp {string range} { + run {string range abcdefghijklmnop 1000 1010} } {} -test string-12.11 {string range} { - string range abcdefghijklmnop -100 end +test string-12.11.$noComp {string range} { + run {string range abcdefghijklmnop -100 end} } {abcdefghijklmnop} -test string-12.12 {string range} { - list [catch {string range abc abc 1} msg] $msg +test string-12.12.$noComp {string range} { + list [catch {run {string range abc abc 1}} msg] $msg } {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}} -test string-12.13 {string range} { - list [catch {string range abc 1 eof} msg] $msg +test string-12.13.$noComp {string range} { + list [catch {run {string range abc 1 eof}} msg] $msg } {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}} -test string-12.14 {string range} { - string range abcdefghijklmnop end-1 end +test string-12.14.$noComp {string range} { + run {string range abcdefghijklmnop end-1 end} } {op} -test string-12.15 {string range} { - string range abcdefghijklmnop end 1000 +test string-12.15.$noComp {string range} { + run {string range abcdefghijklmnop end 1000} } {p} -test string-12.16 {string range} { - string range abcdefghijklmnop end end-1 +test string-12.16.$noComp {string range} { + run {string range abcdefghijklmnop end end-1} } {} -test string-12.17 {string range, unicode} { - string range ab\u7266cdefghijklmnop 5 5 +test string-12.17.$noComp {string range, unicode} { + run {string range ab\u7266cdefghijklmnop 5 5} } e -test string-12.18 {string range, unicode} { - string range ab\u7266cdefghijklmnop 2 3 +test string-12.18.$noComp {string range, unicode} { + run {string range ab\u7266cdefghijklmnop 2 3} } \u7266c -test string-12.19 {string range, bytearray object} { +test string-12.19.$noComp {string range, bytearray object} { set b [binary format I* {0x50515253 0x52}] - set r1 [string range $b 1 end-1] - set r2 [string range $b 1 6] - string equal $r1 $r2 + set r1 [run {string range $b 1 end-1}] + set r2 [run {string range $b 1 6}] + run {string equal $r1 $r2} } 1 -test string-12.20 {string range, out of bounds indices} { - string range \u00ff 0 1 +test string-12.20.$noComp {string range, out of bounds indices} { + run {string range \u00ff 0 1} } \u00ff # Bug 1410553 -test string-12.21 {string range, regenerates correct reps, bug 1410553} { +test string-12.21.$noComp {string range, regenerates correct reps, bug 1410553} { set bytes "\x00 \x03 \x41" set rxBuffer {} foreach ch $bytes { append rxBuffer $ch if {$ch eq "\x03"} { - string length $rxBuffer + run {string length $rxBuffer} } } - set rxCRC [string range $rxBuffer end-1 end] + set rxCRC [run {string range $rxBuffer end-1 end}] binary scan [join $bytes {}] "H*" input_hex binary scan $rxBuffer "H*" rxBuffer_hex binary scan $rxCRC "H*" rxCRC_hex list $input_hex $rxBuffer_hex $rxCRC_hex } {000341 000341 0341} -test string-12.22 {string range, shimmering binary/index} { +test string-12.22.$noComp {string range, shimmering binary/index} { set s 0000000001 binary scan $s a* x - string range $s $s end + run {string range $s $s end} } 000000001 -test string-12.23 {string range, surrogates, bug [11ae2be95dac9417]} fullutf { - list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3] +test string-12.23.$noComp {string range, surrogates, bug [11ae2be95dac9417]} tip389 { + run {list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]} } [list \U100000 {} b] -test string-13.1 {string repeat} { - list [catch {string repeat} msg] $msg +test string-13.1.$noComp {string repeat} { + list [catch {run {string repeat}} msg] $msg } {1 {wrong # args: should be "string repeat string count"}} -test string-13.2 {string repeat} { - list [catch {string repeat abc 10 oops} msg] $msg +test string-13.2.$noComp {string repeat} { + list [catch {run {string repeat abc 10 oops}} msg] $msg } {1 {wrong # args: should be "string repeat string count"}} -test string-13.3 {string repeat} { - string repeat {} 100 +test string-13.3.$noComp {string repeat} { + run {string repeat {} 100} } {} -test string-13.4 {string repeat} { - string repeat { } 5 +test string-13.4.$noComp {string repeat} { + run {string repeat { } 5} } { } -test string-13.5 {string repeat} { - string repeat abc 3 +test string-13.5.$noComp {string repeat} { + run {string repeat abc 3} } {abcabcabc} -test string-13.6 {string repeat} { - string repeat abc -1 +test string-13.6.$noComp {string repeat} { + run {string repeat abc -1} } {} -test string-13.7 {string repeat} { - list [catch {string repeat abc end} msg] $msg +test string-13.7.$noComp {string repeat} { + list [catch {run {string repeat abc end}} msg] $msg } {1 {expected integer but got "end"}} -test string-13.8 {string repeat} { - string repeat {} -1000 +test string-13.8.$noComp {string repeat} { + run {string repeat {} -1000} } {} -test string-13.9 {string repeat} { - string repeat {} 0 +test string-13.9.$noComp {string repeat} { + run {string repeat {} 0} } {} -test string-13.10 {string repeat} { - string repeat def 0 +test string-13.10.$noComp {string repeat} { + run {string repeat def 0} } {} -test string-13.11 {string repeat} { - string repeat def 1 +test string-13.11.$noComp {string repeat} { + run {string repeat def 1} } def -test string-13.12 {string repeat} { - string repeat ab\u7266cd 3 +test string-13.12.$noComp {string repeat} { + run {string repeat ab\u7266cd 3} } ab\u7266cdab\u7266cdab\u7266cd -test string-13.13 {string repeat} { - string repeat \x00 3 +test string-13.13.$noComp {string repeat} { + run {string repeat \x00 3} } \x00\x00\x00 -test string-13.14 {string repeat} { +test string-13.14.$noComp {string repeat} { # The string range will ensure us that string repeat gets a unicode string - string repeat [string range ab\u7266cd 2 3] 3 + run {string repeat [run {string range ab\u7266cd 2 3}] 3} } \u7266c\u7266c\u7266c -test string-14.1 {string replace} { - list [catch {string replace} msg] $msg +test string-14.1.$noComp {string replace} { + list [catch {run {string replace}} msg] $msg } {1 {wrong # args: should be "string replace string first last ?string?"}} -test string-14.2 {string replace} { - list [catch {string replace a 1} msg] $msg +test string-14.2.$noComp {string replace} { + list [catch {run {string replace a 1}} msg] $msg } {1 {wrong # args: should be "string replace string first last ?string?"}} -test string-14.3 {string replace} { - list [catch {string replace a 1 2 3 4} msg] $msg +test string-14.3.$noComp {string replace} { + list [catch {run {string replace a 1 2 3 4}} msg] $msg } {1 {wrong # args: should be "string replace string first last ?string?"}} -test string-14.4 {string replace} { +test string-14.4.$noComp {string replace} { } {} -test string-14.5 {string replace} { - string replace abcdefghijklmnop 2 14 +test string-14.5.$noComp {string replace} { + run {string replace abcdefghijklmnop 2 14} } {abp} -test string-14.6 {string replace} { - string replace abcdefghijklmnop 7 1000 +test string-14.6.$noComp {string replace} { + run {string replace abcdefghijklmnop 7 1000} } {abcdefg} -test string-14.7 {string replace} { - string replace abcdefghijklmnop 10 end +test string-14.7.$noComp {string replace} { + run {string replace abcdefghijklmnop 10 end} } {abcdefghij} -test string-14.8 {string replace} { - string replace abcdefghijklmnop 10 9 +test string-14.8.$noComp {string replace} { + run {string replace abcdefghijklmnop 10 9} } {abcdefghijklmnop} -test string-14.9 {string replace} { - string replace abcdefghijklmnop -3 2 +test string-14.9.$noComp {string replace} { + run {string replace abcdefghijklmnop -3 2} } {defghijklmnop} -test string-14.10 {string replace} { - string replace abcdefghijklmnop -3 -2 +test string-14.10.$noComp {string replace} { + run {string replace abcdefghijklmnop -3 -2} } {abcdefghijklmnop} -test string-14.11 {string replace} { - string replace abcdefghijklmnop 1000 1010 +test string-14.11.$noComp {string replace} { + run {string replace abcdefghijklmnop 1000 1010} } {abcdefghijklmnop} -test string-14.12 {string replace} { - string replace abcdefghijklmnop -100 end +test string-14.12.$noComp {string replace} { + run {string replace abcdefghijklmnop -100 end} } {} -test string-14.13 {string replace} { - list [catch {string replace abc abc 1} msg] $msg +test string-14.13.$noComp {string replace} { + list [catch {run {string replace abc abc 1}} msg] $msg } {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}} -test string-14.14 {string replace} { - list [catch {string replace abc 1 eof} msg] $msg +test string-14.14.$noComp {string replace} { + list [catch {run {string replace abc 1 eof}} msg] $msg } {1 {bad index "eof": must be integer?[+-]integer? or end?[+-]integer?}} -test string-14.15 {string replace} { - string replace abcdefghijklmnop end-10 end-2 NEW +test string-14.15.$noComp {string replace} { + run {string replace abcdefghijklmnop end-10 end-2 NEW} } {abcdeNEWop} -test string-14.16 {string replace} { - string replace abcdefghijklmnop 0 end foo +test string-14.16.$noComp {string replace} { + run {string replace abcdefghijklmnop 0 end foo} } {foo} -test string-14.17 {string replace} { - string replace abcdefghijklmnop end end-1 +test string-14.17.$noComp {string replace} { + run {string replace abcdefghijklmnop end end-1} +} {abcdefghijklmnop} +test string-14.18.$noComp {string replace} { + run {string replace abcdefghijklmnop 10 9 XXX} } {abcdefghijklmnop} +test string-14.19.$noComp {string replace} { + run {string replace {} -1 0 A} +} A +test string-14.20.$noComp {string replace} { + run {string replace [makeByteArray abcdefghijklmnop] end-10 end-2\ + [makeByteArray NEW]} +} {abcdeNEWop} + + +test stringComp-14.21.$noComp {Bug 82e7f67325} { + apply {x { + set a [join $x {}] + lappend b [string length [string replace ___! 0 2 $a]] + lappend b [string length [string replace ___! 0 2 $a[unset a]]] + }} {a b} +} {3 3} +test stringComp-14.22.$noComp {Bug 82e7f67325} memory { + # As in stringComp-14.1, but make sure we don't retain too many refs + leaktest { + apply {x { + set a [join $x {}] + lappend b [string length [string replace ___! 0 2 $a]] + lappend b [string length [string replace ___! 0 2 $a[unset a]]] + }} {a b} + } +} {0} +test stringComp-14.23.$noComp {Bug 0dca3bfa8f} { + apply {arg { + set argCopy $arg + set arg [string replace $arg 1 2 aa] + # Crashes in comparison before fix + expr {$arg ne $argCopy} + }} abcde +} 1 +test stringComp-14.24.$noComp {Bug 1af8de570511} { + apply {{x y} { + # Generate an unshared string value + set val "" + for { set i 0 } { $i < $x } { incr i } { + set val [format "0%s" $val] + } + string replace $val[unset val] 1 1 $y + }} 4 x +} 0x00 +test stringComp-14.25.$noComp {} { + string length [string replace [string repeat a\u00fe 2] 3 end {}] +} 3 -test string-15.1 {string tolower too few args} { - list [catch {string tolower} msg] $msg +test string-15.1.$noComp {string tolower too few args} { + list [catch {run {string tolower}} msg] $msg } {1 {wrong # args: should be "string tolower string ?first? ?last?"}} -test string-15.2 {string tolower bad args} { - list [catch {string tolower a b} msg] $msg +test string-15.2.$noComp {string tolower bad args} { + list [catch {run {string tolower a b}} msg] $msg } {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} -test string-15.3 {string tolower too many args} { - list [catch {string tolower ABC 1 end oops} msg] $msg +test string-15.3.$noComp {string tolower too many args} { + list [catch {run {string tolower ABC 1 end oops}} msg] $msg } {1 {wrong # args: should be "string tolower string ?first? ?last?"}} -test string-15.4 {string tolower} { - string tolower ABCDeF +test string-15.4.$noComp {string tolower} { + run {string tolower ABCDeF} } {abcdef} -test string-15.5 {string tolower} { - string tolower "ABC XyZ" +test string-15.5.$noComp {string tolower} { + run {string tolower "ABC XyZ"} } {abc xyz} -test string-15.6 {string tolower} { - string tolower {123#$&*()} +test string-15.6.$noComp {string tolower} { + run {string tolower {123#$&*()}} } {123#$&*()} -test string-15.7 {string tolower} { - string tolower ABC 1 +test string-15.7.$noComp {string tolower} { + run {string tolower ABC 1} } AbC -test string-15.8 {string tolower} { - string tolower ABC 1 end +test string-15.8.$noComp {string tolower} { + run {string tolower ABC 1 end} } Abc -test string-15.9 {string tolower} { - string tolower ABC 0 end-1 +test string-15.9.$noComp {string tolower} { + run {string tolower ABC 0 end-1} } abC -test string-15.10 {string tolower, unicode} { - string tolower ABCabc\xc7\xe7 +test string-15.10.$noComp {string tolower, unicode} { + run {string tolower ABCabc\xc7\xe7} } "abcabc\xe7\xe7" -test string-15.11 {string tolower, compiled} { - lindex [string tolower [list A B [list C]]] 1 +test string-15.11.$noComp {string tolower, compiled} { + lindex [run {string tolower [list A B [list C]]}] 1 } b -test string-16.1 {string toupper} { - list [catch {string toupper} msg] $msg +test string-16.1.$noComp {string toupper} { + list [catch {run {string toupper}} msg] $msg } {1 {wrong # args: should be "string toupper string ?first? ?last?"}} -test string-16.2 {string toupper} { - list [catch {string toupper a b} msg] $msg +test string-16.2.$noComp {string toupper} { + list [catch {run {string toupper a b}} msg] $msg } {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} -test string-16.3 {string toupper} { - list [catch {string toupper a 1 end oops} msg] $msg +test string-16.3.$noComp {string toupper} { + list [catch {run {string toupper a 1 end oops}} msg] $msg } {1 {wrong # args: should be "string toupper string ?first? ?last?"}} -test string-16.4 {string toupper} { - string toupper abCDEf +test string-16.4.$noComp {string toupper} { + run {string toupper abCDEf} } {ABCDEF} -test string-16.5 {string toupper} { - string toupper "abc xYz" +test string-16.5.$noComp {string toupper} { + run {string toupper "abc xYz"} } {ABC XYZ} -test string-16.6 {string toupper} { - string toupper {123#$&*()} +test string-16.6.$noComp {string toupper} { + run {string toupper {123#$&*()}} } {123#$&*()} -test string-16.7 {string toupper} { - string toupper abc 1 +test string-16.7.$noComp {string toupper} { + run {string toupper abc 1} } aBc -test string-16.8 {string toupper} { - string toupper abc 1 end +test string-16.8.$noComp {string toupper} { + run {string toupper abc 1 end} } aBC -test string-16.9 {string toupper} { - string toupper abc 0 end-1 +test string-16.9.$noComp {string toupper} { + run {string toupper abc 0 end-1} } ABc -test string-16.10 {string toupper, unicode} { - string toupper ABCabc\xc7\xe7 +test string-16.10.$noComp {string toupper, unicode} { + run {string toupper ABCabc\xc7\xe7} } "ABCABC\xc7\xc7" -test string-16.11 {string toupper, compiled} { - lindex [string toupper [list a b [list c]]] 1 +test string-16.11.$noComp {string toupper, compiled} { + lindex [run {string toupper [list a b [list c]]}] 1 } B -test string-17.1 {string totitle} { - list [catch {string totitle} msg] $msg +test string-17.1.$noComp {string totitle} { + list [catch {run {string totitle}} msg] $msg } {1 {wrong # args: should be "string totitle string ?first? ?last?"}} -test string-17.2 {string totitle} { - list [catch {string totitle a b} msg] $msg +test string-17.2.$noComp {string totitle} { + list [catch {run {string totitle a b}} msg] $msg } {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} -test string-17.3 {string totitle} { - string totitle abCDEf +test string-17.3.$noComp {string totitle} { + run {string totitle abCDEf} } {Abcdef} -test string-17.4 {string totitle} { - string totitle "abc xYz" +test string-17.4.$noComp {string totitle} { + run {string totitle "abc xYz"} } {Abc xyz} -test string-17.5 {string totitle} { - string totitle {123#$&*()} +test string-17.5.$noComp {string totitle} { + run {string totitle {123#$&*()}} } {123#$&*()} -test string-17.6 {string totitle, unicode} { - string totitle ABCabc\xc7\xe7 +test string-17.6.$noComp {string totitle, unicode} { + run {string totitle ABCabc\xc7\xe7} } "Abcabc\xe7\xe7" -test string-17.7 {string totitle, unicode} { - string totitle \u01f3BCabc\xc7\xe7 +test string-17.7.$noComp {string totitle, unicode} { + run {string totitle \u01f3BCabc\xc7\xe7} } "\u01f2bcabc\xe7\xe7" -test string-17.8 {string totitle, compiled} { - lindex [string totitle [list aa bb [list cc]]] 0 +test string-17.8.$noComp {string totitle, compiled} { + lindex [run {string totitle [list aa bb [list cc]]}] 0 } Aa +test string-17.9.$noComp {string totitle, surrogates, bug [11ae2be95dac9417]} tip389 { + run {list [string totitle a\U118c0c 1 1] [string totitle a\U118c0c 2 2] \ + [string totitle a\U118c0c 3 3]} +} [list a\U118a0c a\U118c0C a\U118c0C] -test string-18.1 {string trim} { - list [catch {string trim} msg] $msg +test string-18.1.$noComp {string trim} { + list [catch {run {string trim}} msg] $msg } {1 {wrong # args: should be "string trim string ?chars?"}} -test string-18.2 {string trim} { - list [catch {string trim a b c} msg] $msg +test string-18.2.$noComp {string trim} { + list [catch {run {string trim a b c}} msg] $msg } {1 {wrong # args: should be "string trim string ?chars?"}} -test string-18.3 {string trim} { - string trim " XYZ " +test string-18.3.$noComp {string trim} { + run {string trim " XYZ "} } {XYZ} -test string-18.4 {string trim} { - string trim "\t\nXYZ\t\n\r\n" +test string-18.4.$noComp {string trim} { + run {string trim "\t\nXYZ\t\n\r\n"} } {XYZ} -test string-18.5 {string trim} { - string trim " A XYZ A " +test string-18.5.$noComp {string trim} { + run {string trim " A XYZ A "} } {A XYZ A} -test string-18.6 {string trim} { - string trim "XXYYZZABC XXYYZZ" ZYX +test string-18.6.$noComp {string trim} { + run {string trim "XXYYZZABC XXYYZZ" ZYX} } {ABC } -test string-18.7 {string trim} { - string trim " \t\r " +test string-18.7.$noComp {string trim} { + run {string trim " \t\r "} } {} -test string-18.8 {string trim} { - string trim {abcdefg} {} +test string-18.8.$noComp {string trim} { + run {string trim {abcdefg} {}} } {abcdefg} -test string-18.9 {string trim} { - string trim {} +test string-18.9.$noComp {string trim} { + run {string trim {}} } {} -test string-18.10 {string trim} { - string trim ABC DEF +test string-18.10.$noComp {string trim} { + run {string trim ABC DEF} } {ABC} -test string-18.11 {string trim, unicode} { - string trim "\xe7\xe8 AB\xe7C \xe8\xe7" \xe7\xe8 +test string-18.11.$noComp {string trim, unicode} { + run {string trim "\xe7\xe8 AB\xe7C \xe8\xe7" \xe7\xe8} } " AB\xe7C " -test string-18.12 {string trim, unicode default} { - string trim \ufeff\x00\u0085\u00a0\u1680\u180eABC\u1361\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u200b\u2028\u2029\u202f\u205f\u3000 +test string-18.12.$noComp {string trim, unicode default} { + run {string trim \ufeff\x00\u0085\u00a0\u1680\u180eABC\u1361\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u200b\u2028\u2029\u202f\u205f\u3000} } ABC\u1361 -test string-19.1 {string trimleft} { - list [catch {string trimleft} msg] $msg +test string-19.1.$noComp {string trimleft} { + list [catch {run {string trimleft}} msg] $msg } {1 {wrong # args: should be "string trimleft string ?chars?"}} -test string-19.2 {string trimleft} { - string trimleft " XYZ " +test string-19.2.$noComp {string trimleft} { + run {string trimleft " XYZ "} } {XYZ } -test string-19.3 {string trimleft, unicode default} { - string trimleft \ufeff\u0085\u00a0\x00\u1680\u180e\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u200b\u2028\u2029\u202f\u205f\u3000\u1361ABC +test string-19.3.$noComp {string trimleft, unicode default} { + run {string trimleft \ufeff\u0085\u00a0\x00\u1680\u180e\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u200b\u2028\u2029\u202f\u205f\u3000\u1361ABC} } \u1361ABC -test string-20.1 {string trimright errors} { - list [catch {string trimright} msg] $msg +test string-20.1.$noComp {string trimright errors} { + list [catch {run {string trimright}} msg] $msg } {1 {wrong # args: should be "string trimright string ?chars?"}} -test string-20.2 {string trimright errors} { - list [catch {string trimg a} msg] $msg +test string-20.2.$noComp {string trimright errors} { + list [catch {run {string trimg a}} msg] $msg } {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} -test string-20.3 {string trimright} { - string trimright " XYZ " +test string-20.3.$noComp {string trimright} { + run {string trimright " XYZ "} } { XYZ} -test string-20.4 {string trimright} { - string trimright " " +test string-20.4.$noComp {string trimright} { + run {string trimright " "} } {} -test string-20.5 {string trimright} { - string trimright "" +test string-20.5.$noComp {string trimright} { + run {string trimright ""} } {} -test string-20.6 {string trimright, unicode default} { - string trimright ABC\u1361\u0085\x00\u00a0\u1680\u180e\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u200b\u2028\u2029\u202f\u205f\u3000 +test string-20.6.$noComp {string trimright, unicode default} { + run {string trimright ABC\u1361\u0085\x00\u00a0\u1680\u180e\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u200b\u2028\u2029\u202f\u205f\u3000} } ABC\u1361 -test string-21.1 {string wordend} { - list [catch {string wordend a} msg] $msg +test string-21.1.$noComp {string wordend} { + list [catch {run {string wordend a}} msg] $msg } {1 {wrong # args: should be "string wordend string index"}} -test string-21.2 {string wordend} { - list [catch {string wordend a b c} msg] $msg +test string-21.2.$noComp {string wordend} { + list [catch {run {string wordend a b c}} msg] $msg } {1 {wrong # args: should be "string wordend string index"}} -test string-21.3 {string wordend} { - list [catch {string wordend a gorp} msg] $msg +test string-21.3.$noComp {string wordend} { + list [catch {run {string wordend a gorp}} msg] $msg } {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}} -test string-21.4 {string wordend} { - string wordend abc. -1 +test string-21.4.$noComp {string wordend} { + run {string wordend abc. -1} } 3 -test string-21.5 {string wordend} { - string wordend abc. 100 +test string-21.5.$noComp {string wordend} { + run {string wordend abc. 100} } 4 -test string-21.6 {string wordend} { - string wordend "word_one two three" 2 +test string-21.6.$noComp {string wordend} { + run {string wordend "word_one two three" 2} } 8 -test string-21.7 {string wordend} { - string wordend "one .&# three" 5 +test string-21.7.$noComp {string wordend} { + run {string wordend "one .&# three" 5} } 6 -test string-21.8 {string wordend} { - string worde "x.y" 0 +test string-21.8.$noComp {string wordend} { + run {string worde "x.y" 0} } 1 -test string-21.9 {string wordend} { - string worde "x.y" end-1 +test string-21.9.$noComp {string wordend} { + run {string worde "x.y" end-1} } 2 -test string-21.10 {string wordend, unicode} { - string wordend "xyz\u00c7de fg" 0 +test string-21.10.$noComp {string wordend, unicode} { + run {string wordend "xyz\u00c7de fg" 0} } 6 -test string-21.11 {string wordend, unicode} { - string wordend "xyz\uc700de fg" 0 +test string-21.11.$noComp {string wordend, unicode} { + run {string wordend "xyz\uc700de fg" 0} } 6 -test string-21.12 {string wordend, unicode} { - string wordend "xyz\u203fde fg" 0 +test string-21.12.$noComp {string wordend, unicode} { + run {string wordend "xyz\u203fde fg" 0} } 6 -test string-21.13 {string wordend, unicode} { - string wordend "xyz\u2045de fg" 0 +test string-21.13.$noComp {string wordend, unicode} { + run {string wordend "xyz\u2045de fg" 0} } 3 -test string-21.14 {string wordend, unicode} { - string wordend "\uc700\uc700 abc" 8 +test string-21.14.$noComp {string wordend, unicode} { + run {string wordend "\uc700\uc700 abc" 8} } 6 -test string-22.1 {string wordstart} { - list [catch {string word a} msg] $msg +test string-22.1.$noComp {string wordstart} { + list [catch {run {string word a}} msg] $msg } {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} -test string-22.2 {string wordstart} { - list [catch {string wordstart a} msg] $msg +test string-22.2.$noComp {string wordstart} { + list [catch {run {string wordstart a}} msg] $msg } {1 {wrong # args: should be "string wordstart string index"}} -test string-22.3 {string wordstart} { - list [catch {string wordstart a b c} msg] $msg +test string-22.3.$noComp {string wordstart} { + list [catch {run {string wordstart a b c}} msg] $msg } {1 {wrong # args: should be "string wordstart string index"}} -test string-22.4 {string wordstart} { - list [catch {string wordstart a gorp} msg] $msg +test string-22.4.$noComp {string wordstart} { + list [catch {run {string wordstart a gorp}} msg] $msg } {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}} -test string-22.5 {string wordstart} { - string wordstart "one two three_words" 400 +test string-22.5.$noComp {string wordstart} { + run {string wordstart "one two three_words" 400} } 8 -test string-22.6 {string wordstart} { - string wordstart "one two three_words" 2 +test string-22.6.$noComp {string wordstart} { + run {string wordstart "one two three_words" 2} } 0 -test string-22.7 {string wordstart} { - string wordstart "one two three_words" -2 +test string-22.7.$noComp {string wordstart} { + run {string wordstart "one two three_words" -2} } 0 -test string-22.8 {string wordstart} { - string wordstart "one .*&^ three" 6 +test string-22.8.$noComp {string wordstart} { + run {string wordstart "one .*&^ three" 6} } 6 -test string-22.9 {string wordstart} { - string wordstart "one two three" 4 +test string-22.9.$noComp {string wordstart} { + run {string wordstart "one two three" 4} } 4 -test string-22.10 {string wordstart} { - string wordstart "one two three" end-5 +test string-22.10.$noComp {string wordstart} { + run {string wordstart "one two three" end-5} } 7 -test string-22.11 {string wordstart, unicode} { - string wordstart "one tw\u00c7o three" 7 +test string-22.11.$noComp {string wordstart, unicode} { + run {string wordstart "one tw\u00c7o three" 7} } 4 -test string-22.12 {string wordstart, unicode} { - string wordstart "ab\uc700\uc700 cdef ghi" 12 +test string-22.12.$noComp {string wordstart, unicode} { + run {string wordstart "ab\uc700\uc700 cdef ghi" 12} } 10 -test string-22.13 {string wordstart, unicode} { - string wordstart "\uc700\uc700 abc" 8 +test string-22.13.$noComp {string wordstart, unicode} { + run {string wordstart "\uc700\uc700 abc" 8} } 3 -test string-23.0 {string is boolean, Bug 1187123} testindexobj { +test string-23.0.$noComp {string is boolean, Bug 1187123} testindexobj { set x 5 catch {testindexobj $x foo bar soom} - string is boolean $x + run {string is boolean $x} } 0 -test string-23.1 {string is command with empty string} { +test string-23.1.$noComp {string is command with empty string} { set s "" list \ - [string is alnum $s] \ - [string is alpha $s] \ - [string is ascii $s] \ - [string is control $s] \ - [string is boolean $s] \ - [string is digit $s] \ - [string is double $s] \ - [string is false $s] \ - [string is graph $s] \ - [string is integer $s] \ - [string is lower $s] \ - [string is print $s] \ - [string is punct $s] \ - [string is space $s] \ - [string is true $s] \ - [string is upper $s] \ - [string is wordchar $s] \ - [string is xdigit $s] \ + [run {string is alnum $s}] \ + [run {string is alpha $s}] \ + [run {string is ascii $s}] \ + [run {string is control $s}] \ + [run {string is boolean $s}] \ + [run {string is digit $s}] \ + [run {string is double $s}] \ + [run {string is false $s}] \ + [run {string is graph $s}] \ + [run {string is integer $s}] \ + [run {string is lower $s}] \ + [run {string is print $s}] \ + [run {string is punct $s}] \ + [run {string is space $s}] \ + [run {string is true $s}] \ + [run {string is upper $s}] \ + [run {string is wordchar $s}] \ + [run {string is xdigit $s}] \ } {1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1} -test string-23.2 {string is command with empty string} { +test string-23.2.$noComp {string is command with empty string} { set s "" list \ - [string is alnum -strict $s] \ - [string is alpha -strict $s] \ - [string is ascii -strict $s] \ - [string is control -strict $s] \ - [string is boolean -strict $s] \ - [string is digit -strict $s] \ - [string is double -strict $s] \ - [string is false -strict $s] \ - [string is graph -strict $s] \ - [string is integer -strict $s] \ - [string is lower -strict $s] \ - [string is print -strict $s] \ - [string is punct -strict $s] \ - [string is space -strict $s] \ - [string is true -strict $s] \ - [string is upper -strict $s] \ - [string is wordchar -strict $s] \ - [string is xdigit -strict $s] \ + [run {string is alnum -strict $s}] \ + [run {string is alpha -strict $s}] \ + [run {string is ascii -strict $s}] \ + [run {string is control -strict $s}] \ + [run {string is boolean -strict $s}] \ + [run {string is digit -strict $s}] \ + [run {string is double -strict $s}] \ + [run {string is false -strict $s}] \ + [run {string is graph -strict $s}] \ + [run {string is integer -strict $s}] \ + [run {string is lower -strict $s}] \ + [run {string is print -strict $s}] \ + [run {string is punct -strict $s}] \ + [run {string is space -strict $s}] \ + [run {string is true -strict $s}] \ + [run {string is upper -strict $s}] \ + [run {string is wordchar -strict $s}] \ + [run {string is xdigit -strict $s}] \ } {0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0} -test string-24.1 {string reverse command} -body { - string reverse +test string-24.1.$noComp {string reverse command} -body { + run {string reverse} } -returnCodes error -result "wrong # args: should be \"string reverse string\"" -test string-24.2 {string reverse command} -body { - string reverse a b +test string-24.2.$noComp {string reverse command} -body { + run {string reverse a b} } -returnCodes error -result "wrong # args: should be \"string reverse string\"" -test string-24.3 {string reverse command - shared string} { +test string-24.3.$noComp {string reverse command - shared string} { set x abcde - string reverse $x + run {string reverse $x} } edcba -test string-24.4 {string reverse command - unshared string} { +test string-24.4.$noComp {string reverse command - unshared string} { set x abc set y de - string reverse $x$y + run {string reverse $x$y} } edcba -test string-24.5 {string reverse command - shared unicode string} { +test string-24.5.$noComp {string reverse command - shared unicode string} { set x abcde\ud0ad - string reverse $x + run {string reverse $x} } \ud0adedcba -test string-24.6 {string reverse command - unshared string} { +test string-24.6.$noComp {string reverse command - unshared string} { set x abc set y de\ud0ad - string reverse $x$y + run {string reverse $x$y} } \ud0adedcba -test string-24.7 {string reverse command - simple case} { - string reverse a +test string-24.7.$noComp {string reverse command - simple case} { + run {string reverse a} } a -test string-24.8 {string reverse command - simple case} { - string reverse \ud0ad +test string-24.8.$noComp {string reverse command - simple case} { + run {string reverse \ud0ad} } \ud0ad -test string-24.9 {string reverse command - simple case} { - string reverse {} +test string-24.9.$noComp {string reverse command - simple case} { + run {string reverse {}} } {} -test string-24.10 {string reverse command - corner case} { +test string-24.10.$noComp {string reverse command - corner case} { set x \ubeef\ud0ad - string reverse $x + run {string reverse $x} } \ud0ad\ubeef -test string-24.11 {string reverse command - corner case} { +test string-24.11.$noComp {string reverse command - corner case} { set x \ubeef set y \ud0ad - string reverse $x$y + run {string reverse $x$y} } \ud0ad\ubeef -test string-24.12 {string reverse command - corner case} { +test string-24.12.$noComp {string reverse command - corner case} { set x \ubeef set y \ud0ad - string is ascii [string reverse $x$y] + run {string is ascii [run {string reverse $x$y}]} } 0 -test string-24.13 {string reverse command - pure Unicode string} { - string reverse [string range \ubeef\ud0ad\ubeef\ud0ad\ubeef\ud0ad 1 5] +test string-24.13.$noComp {string reverse command - pure Unicode string} { + run {string reverse [run {string range \ubeef\ud0ad\ubeef\ud0ad\ubeef\ud0ad 1 5}]} } \ud0ad\ubeef\ud0ad\ubeef\ud0ad -test string-24.14 {string reverse command - pure bytearray} { - binary scan [string reverse [binary format H* 010203]] H* x +test string-24.14.$noComp {string reverse command - pure bytearray} { + binary scan [run {string reverse [binary format H* 010203]}] H* x set x } 030201 -test string-24.15 {string reverse command - pure bytearray} { - binary scan [tcl::string::reverse [binary format H* 010203]] H* x +test string-24.15.$noComp {string reverse command - pure bytearray} { + binary scan [run {tcl::string::reverse [binary format H* 010203]}] H* x set x } 030201 -test string-25.1 {string is list} { - string is list {a b c} +test string-25.1.$noComp {string is list} { + run {string is list {a b c}} } 1 -test string-25.2 {string is list} { - string is list "a \{b c" +test string-25.2.$noComp {string is list} { + run {string is list "a \{b c"} } 0 -test string-25.3 {string is list} { - string is list {a {b c}d e} +test string-25.3.$noComp {string is list} { + run {string is list {a {b c}d e}} } 0 -test string-25.4 {string is list} { - string is list {} +test string-25.4.$noComp {string is list} { + run {string is list {}} } 1 -test string-25.5 {string is list} { - string is list -strict {a b c} +test string-25.5.$noComp {string is list} { + run {string is list -strict {a b c}} } 1 -test string-25.6 {string is list} { - string is list -strict "a \{b c" +test string-25.6.$noComp {string is list} { + run {string is list -strict "a \{b c"} } 0 -test string-25.7 {string is list} { - string is list -strict {a {b c}d e} +test string-25.7.$noComp {string is list} { + run {string is list -strict {a {b c}d e}} } 0 -test string-25.8 {string is list} { - string is list -strict {} +test string-25.8.$noComp {string is list} { + run {string is list -strict {}} } 1 -test string-25.9 {string is list} { +test string-25.9.$noComp {string is list} { set x {} - list [string is list -failindex x {a b c}] $x + list [run {string is list -failindex x {a b c}}] $x } {1 {}} -test string-25.10 {string is list} { +test string-25.10.$noComp {string is list} { set x {} - list [string is list -failindex x "a \{b c"] $x + list [run {string is list -failindex x "a \{b c"}] $x } {0 2} -test string-25.11 {string is list} { +test string-25.11.$noComp {string is list} { set x {} - list [string is list -failindex x {a b {b c}d e}] $x + list [run {string is list -failindex x {a b {b c}d e}}] $x } {0 4} -test string-25.12 {string is list} { +test string-25.12.$noComp {string is list} { set x {} - list [string is list -failindex x {}] $x + list [run {string is list -failindex x {}}] $x } {1 {}} -test string-25.13 {string is list} { +test string-25.13.$noComp {string is list} { set x {} - list [string is list -failindex x { {b c}d e}] $x + list [run {string is list -failindex x { {b c}d e}}] $x } {0 2} -test string-25.14 {string is list} { +test string-25.14.$noComp {string is list} { set x {} - list [string is list -failindex x "\uabcd {b c}d e"] $x + list [run {string is list -failindex x "\uabcd {b c}d e"}] $x } {0 2} -test string-26.1 {tcl::prefix, too few args} -body { +test string-26.1.$noComp {tcl::prefix, too few args} -body { tcl::prefix match a } -returnCodes 1 -result {wrong # args: should be "tcl::prefix match ?options? table string"} -test string-26.2 {tcl::prefix, bad args} -body { +test string-26.2.$noComp {tcl::prefix, bad args} -body { tcl::prefix match a b c } -returnCodes 1 -result {bad option "a": must be -error, -exact, or -message} -test string-26.2.1 {tcl::prefix, empty table} -body { +test string-26.2.1.$noComp {tcl::prefix, empty table} -body { tcl::prefix match {} foo } -returnCodes 1 -result {bad option "foo": no valid options} -test string-26.3 {tcl::prefix, bad args} -body { +test string-26.3.$noComp {tcl::prefix, bad args} -body { tcl::prefix match -error "{}x" -exact str1 str2 } -returnCodes 1 -result {list element in braces followed by "x" instead of space} -test string-26.3.1 {tcl::prefix, bad args} -body { +test string-26.3.1.$noComp {tcl::prefix, bad args} -body { tcl::prefix match -error "x" -exact str1 str2 } -returnCodes 1 -result {error options must have an even number of elements} -test string-26.3.2 {tcl::prefix, bad args} -body { +test string-26.3.2.$noComp {tcl::prefix, bad args} -body { tcl::prefix match -error str1 str2 } -returnCodes 1 -result {missing value for -error} -test string-26.4 {tcl::prefix, bad args} -body { +test string-26.4.$noComp {tcl::prefix, bad args} -body { tcl::prefix match -message str1 str2 } -returnCodes 1 -result {missing value for -message} -test string-26.5 {tcl::prefix} { +test string-26.5.$noComp {tcl::prefix} { tcl::prefix match {apa bepa cepa depa} cepa } cepa -test string-26.6 {tcl::prefix} { +test string-26.6.$noComp {tcl::prefix} { tcl::prefix match {apa bepa cepa depa} be } bepa -test string-26.7 {tcl::prefix} -body { +test string-26.7.$noComp {tcl::prefix} -body { tcl::prefix match -exact {apa bepa cepa depa} be } -returnCodes 1 -result {bad option "be": must be apa, bepa, cepa, or depa} -test string-26.8 {tcl::prefix} -body { +test string-26.8.$noComp {tcl::prefix} -body { tcl::prefix match -message wombat {apa bepa bear depa} be } -returnCodes 1 -result {ambiguous wombat "be": must be apa, bepa, bear, or depa} -test string-26.9 {tcl::prefix} -body { +test string-26.9.$noComp {tcl::prefix} -body { tcl::prefix match -error {} {apa bepa bear depa} be } -returnCodes 0 -result {} -test string-26.10 {tcl::prefix} -body { +test string-26.10.$noComp {tcl::prefix} -body { tcl::prefix match -error {-level 1} {apa bepa bear depa} be } -returnCodes 2 -result {ambiguous option "be": must be apa, bepa, bear, or depa} -test string-26.10.1 {tcl::prefix} -setup { +test string-26.10.1.$noComp {tcl::prefix} -setup { proc _testprefix {args} { array set opts {-a x -b y -c y} foreach {opt val} $args { @@ -1853,7 +2114,7 @@ proc MemStress {args} { return $res } -test string-26.11 {tcl::prefix: testing for leaks} -body { +test string-26.11.$noComp {tcl::prefix: testing for leaks} -body { # This test is made to stress object reference management MemStress { set table {hejj miff gurk} @@ -1874,7 +2135,7 @@ test string-26.11 {tcl::prefix: testing for leaks} -body { } } -constraints memory -result {0 0 0} -test string-26.12 {tcl::prefix: testing for leaks} -body { +test string-26.12.$noComp {tcl::prefix: testing for leaks} -body { # This is a memory leak test in a form that might actually happen # in real code. The shared literal "miff" causes a connection # between the item and the table. @@ -1892,7 +2153,7 @@ test string-26.12 {tcl::prefix: testing for leaks} -body { } } -constraints memory -result 0 -test string-26.13 {tcl::prefix: testing for leaks} -body { +test string-26.13.$noComp {tcl::prefix: testing for leaks} -body { # This test is made to stress object reference management MemStress { set table [list hejj miff] @@ -1905,177 +2166,232 @@ test string-26.13 {tcl::prefix: testing for leaks} -body { } } -constraints memory -result {0} -test string-27.1 {tcl::prefix all, too few args} -body { +test string-27.1.$noComp {tcl::prefix all, too few args} -body { tcl::prefix all a } -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"} -test string-27.2 {tcl::prefix all, bad args} -body { +test string-27.2.$noComp {tcl::prefix all, bad args} -body { tcl::prefix all a b c } -returnCodes 1 -result {wrong # args: should be "tcl::prefix all table string"} -test string-27.3 {tcl::prefix all, bad args} -body { +test string-27.3.$noComp {tcl::prefix all, bad args} -body { tcl::prefix all "{}x" str2 } -returnCodes 1 -result {list element in braces followed by "x" instead of space} -test string-27.4 {tcl::prefix all} { +test string-27.4.$noComp {tcl::prefix all} { tcl::prefix all {apa bepa cepa depa} c } cepa -test string-27.5 {tcl::prefix all} { +test string-27.5.$noComp {tcl::prefix all} { tcl::prefix all {apa bepa cepa depa} cepa } cepa -test string-27.6 {tcl::prefix all} { +test string-27.6.$noComp {tcl::prefix all} { tcl::prefix all {apa bepa cepa depa} cepax } {} -test string-27.7 {tcl::prefix all} { +test string-27.7.$noComp {tcl::prefix all} { tcl::prefix all {apa aska appa} a } {apa aska appa} -test string-27.8 {tcl::prefix all} { +test string-27.8.$noComp {tcl::prefix all} { tcl::prefix all {apa aska appa} ap } {apa appa} -test string-27.9 {tcl::prefix all} { +test string-27.9.$noComp {tcl::prefix all} { tcl::prefix all {apa aska appa} p } {} -test string-27.10 {tcl::prefix all} { +test string-27.10.$noComp {tcl::prefix all} { tcl::prefix all {apa aska appa} {} } {apa aska appa} -test string-28.1 {tcl::prefix longest, too few args} -body { +test string-28.1.$noComp {tcl::prefix longest, too few args} -body { tcl::prefix longest a } -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"} -test string-28.2 {tcl::prefix longest, bad args} -body { +test string-28.2.$noComp {tcl::prefix longest, bad args} -body { tcl::prefix longest a b c } -returnCodes 1 -result {wrong # args: should be "tcl::prefix longest table string"} -test string-28.3 {tcl::prefix longest, bad args} -body { +test string-28.3.$noComp {tcl::prefix longest, bad args} -body { tcl::prefix longest "{}x" str2 } -returnCodes 1 -result {list element in braces followed by "x" instead of space} -test string-28.4 {tcl::prefix longest} { +test string-28.4.$noComp {tcl::prefix longest} { tcl::prefix longest {apa bepa cepa depa} c } cepa -test string-28.5 {tcl::prefix longest} { +test string-28.5.$noComp {tcl::prefix longest} { tcl::prefix longest {apa bepa cepa depa} cepa } cepa -test string-28.6 {tcl::prefix longest} { +test string-28.6.$noComp {tcl::prefix longest} { tcl::prefix longest {apa bepa cepa depa} cepax } {} -test string-28.7 {tcl::prefix longest} { +test string-28.7.$noComp {tcl::prefix longest} { tcl::prefix longest {apa aska appa} a } a -test string-28.8 {tcl::prefix longest} { +test string-28.8.$noComp {tcl::prefix longest} { tcl::prefix longest {apa aska appa} ap } ap -test string-28.9 {tcl::prefix longest} { +test string-28.9.$noComp {tcl::prefix longest} { tcl::prefix longest {apa bska appa} a } ap -test string-28.10 {tcl::prefix longest} { +test string-28.10.$noComp {tcl::prefix longest} { tcl::prefix longest {apa bska appa} {} } {} -test string-28.11 {tcl::prefix longest} { +test string-28.11.$noComp {tcl::prefix longest} { tcl::prefix longest {{} bska appa} {} } {} -test string-28.12 {tcl::prefix longest} { +test string-28.12.$noComp {tcl::prefix longest} { tcl::prefix longest {apa {} appa} {} } {} -test string-28.13 {tcl::prefix longest} { +test string-28.13.$noComp {tcl::prefix longest} { # Test UTF8 handling tcl::prefix longest {ax\x90 bep ax\x91} a } ax -test string-29.1 {string cat, no arg} { - string cat +test string-29.1.$noComp {string cat, no arg} { + run {string cat} } "" -test string-29.2 {string cat, single arg} { +test string-29.2.$noComp {string cat, single arg} { set x FOO - string compare $x [string cat $x] + run {string compare $x [run {string cat $x}]} } 0 -test string-29.3 {string cat, two args} { +test string-29.3.$noComp {string cat, two args} { set x FOO - string compare $x$x [string cat $x $x] + run {string compare $x$x [run {string cat $x $x}]} } 0 -test string-29.4 {string cat, many args} { +test string-29.4.$noComp {string cat, many args} { set x FOO set n 260 - set xx [string repeat $x $n] - set vv [string repeat {$x} $n] - set vvs [string repeat {$x } $n] - set r1 [string compare $xx [subst $vv]] - set r2 [string compare $xx [eval "string cat $vvs"]] + set xx [run {string repeat $x $n}] + set vv [run {string repeat {$x} $n}] + set vvs [run {string repeat {$x } $n}] + set r1 [run {string compare $xx [subst $vv]}] + set r2 [run {string compare $xx [eval "run {string cat $vvs}"]}] list $r1 $r2 } {0 0} +if {$noComp} { +test string-29.5.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat [list x] [list]}] +} -match glob -result {*no string representation} +test string-29.6.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat [list] [list x]}] +} -match glob -result {*no string representation} +test string-29.7.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat [list x] [list] [list]}] +} -match glob -result {*no string representation} +test string-29.8.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat [list] [list x] [list]}] +} -match glob -result {*no string representation} +test string-29.9.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat [list] [list] [list x]}] +} -match glob -result {*no string representation} +test string-29.10.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat [list x] [list x]}] +} -match glob -result {*, string representation "xx"} +test string-29.11.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation \ + [run {string cat [list x] [encoding convertto utf-8 {}]}] +} -match glob -result {*no string representation} +test string-29.12.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation \ + [run {string cat [encoding convertto utf-8 {}] [list x]}] +} -match glob -result {*, string representation "x"} +test string-29.13.$noComp {string cat, efficiency} -body { + tcl::unsupported::representation [run {string cat \ + [encoding convertto utf-8 {}] [encoding convertto utf-8 {}] [list x]}] +} -match glob -result {*, string representation "x"} +test string-29.14.$noComp {string cat, efficiency} -setup { + set e [encoding convertto utf-8 {}] +} -cleanup { + unset e +} -body { + tcl::unsupported::representation [run {string cat $e $e [list x]}] +} -match glob -result {*no string representation} +test string-29.15.$noComp {string cat, efficiency} -setup { + set e [encoding convertto utf-8 {}] + set f [encoding convertto utf-8 {}] +} -cleanup { + unset e f +} -body { + 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 -test string-30.1 {string is dict} { +test string-31.1 {string is dict} { string is dict {a b c d} } 1 -test string-30.1a {string is dict} { +test string-31.1a {string is dict} { string is dict {a b c} } 0 - -test string-30.2 {string is dict} { +test string-31.2 {string is dict} { string is dict "a \{b c" } 0 -test string-30.3 {string is dict} { +test string-31.3 {string is dict} { string is dict {a {b c}d e} } 0 -test string-30.4 {string is dict} { +test string-31.4 {string is dict} { string is dict {} } 1 -test string-30.5 {string is dict} { +test string-31.5 {string is dict} { string is dict -strict {a b c d} } 1 -test string-30.5a {string is dict} { +test string-31.5a {string is dict} { string is dict -strict {a b c} } 0 - -test string-30.6 {string is dict} { +test string-31.6 {string is dict} { string is dict -strict "a \{b c" } 0 -test string-30.7 {string is dict} { +test string-31.7 {string is dict} { string is dict -strict {a {b c}d e} } 0 -test string-30.8 {string is dict} { +test string-31.8 {string is dict} { string is dict -strict {} } 1 -test string-30.9 {string is dict} { +test string-31.9 {string is dict} { set x {} list [string is dict -failindex x {a b c d}] $x } {1 {}} -test string-30.9a {string is dict} { +test string-31.9a {string is dict} { set x {} list [string is dict -failindex x {a b c}] $x } {0 0} -test string-30.10 {string is dict} { +test string-31.10 {string is dict} { set x {} list [string is dict -failindex x "a \{b c d"] $x } {0 0} -test string-30.10a {string is dict} { +test string-31.10a {string is dict} { set x {} list [string is dict -failindex x "a \{b c"] $x } {0 0} -test string-30.11 {string is dict} { +test string-31.11 {string is dict} { set x {} list [string is dict -failindex x {a b {b c}d e}] $x } {0 0} -test string-30.12 {string is dict} { +test string-31.12 {string is dict} { set x {} list [string is dict -failindex x {}] $x } {1 {}} -test string-30.13 {string is dict} { +test string-31.13 {string is dict} { set x {} list [string is dict -failindex x { {b c}d e}] $x } {0 0} -test string-30.14 {string is dict} { +test string-31.14 {string is dict} { set x {} list [string is dict -failindex x "\uabcd {b c}d e"] $x } {0 0} -test string-30.15 {string is dict, valid dict} { +test string-31.15 {string is dict, valid dict} { string is dict {a b c d e f} } 1 -test string-30.16 {string is dict, invalid dict} { +test string-31.16 {string is dict, invalid dict} { string is dict a } 0 -test string-30.17 {string is dict, valid dict packed in invalid dict} { +test string-31.17 {string is dict, valid dict packed in invalid dict} { string is dict {{a b c d e f g h}} } 0 - + # cleanup rename MemStress {} +rename makeByteArray {} +rename makeUnicode {} +rename makeList {} +rename makeShared {} catch {rename foo {}} ::tcltest::cleanupTests return diff --git a/tests/stringComp.test b/tests/stringComp.test deleted file mode 100644 index 2aeb08e..0000000 --- a/tests/stringComp.test +++ /dev/null @@ -1,801 +0,0 @@ -# Commands covered: string -# -# 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. -# -# This differs from the original string tests in that the tests call -# things in procs, which uses the compiled string code instead of -# the runtime parse string code. The tests of import should match -# their equivalent number in string.test. -# -# Copyright (c) 2001 by ActiveState Corporation. -# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. -# -# 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 - namespace import -force ::tcltest::* -} - -::tcltest::loadTestedCommands -catch [list package require -exact Tcltest [info patchlevel]] - -# Some tests require the testobj command - -testConstraint testobj [expr {[info commands testobj] != {}}] -testConstraint memory [llength [info commands memory]] -if {[testConstraint memory]} { - proc getbytes {} { - set lines [split [memory info] \n] - return [lindex $lines 3 3] - } - proc leaktest {script {iterations 3}} { - set end [getbytes] - for {set i 0} {$i < $iterations} {incr i} { - uplevel 1 $script - set tmp $end - set end [getbytes] - } - return [expr {$end - $tmp}] - } -} - -test stringComp-1.1 {error conditions} { - proc foo {} {string gorp a b} - list [catch {foo} msg] $msg -} {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} -test stringComp-1.2 {error conditions} { - proc foo {} {string} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string subcommand ?arg ...?"}} -test stringComp-1.3 {error condition - undefined method during compile} { - # We don't want this to complain about 'never' because it may never - # be called, or string may get redefined. This must compile OK. - proc foo {str i} { - if {"yes" == "no"} { string never called but complains here } - string index $str $i - } - foo abc 0 -} a - -## Test string compare|equal over equal constraints -## Use result for string compare, and negate it for string equal -## The body will be tested both in and outside a proc -set i 0 -foreach {tname tbody tresult tcode} { - {too few args} { - string compare a - } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} - {bad args} { - string compare a b c - } {bad option "a": must be -nocase or -length} {error} - {bad args} { - string compare -length -nocase str1 str2 - } {expected integer but got "-nocase"} {error} - {too many args} { - string compare -length 10 -nocase str1 str2 str3 - } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} - {compare with length unspecified} { - string compare -length 10 10 - } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} - {basic operation fail} { - string compare abcde abdef - } {-1} {} - {basic operation success} { - string compare abcde abcde - } {0} {} - {with length} { - string compare -length 2 abcde abxyz - } {0} {} - {with special index} { - string compare -length end-3 abcde abxyz - } {expected integer but got "end-3"} {error} - {unicode} { - string compare ab\u7266 ab\u7267 - } {-1} {} - {unicode} {string compare \334 \u00dc} 0 {} - {unicode} {string compare \334 \u00fc} -1 {} - {unicode} {string compare \334\334\334\374\374 \334\334\334\334\334} 1 {} - {high bit} { - # This test will fail if the underlying comparaison - # is using signed chars instead of unsigned chars. - # (like SunOS's default memcmp thus the compat/memcmp.c) - string compare "\x80" "@" - # Nb this tests works also in utf8 space because \x80 is - # translated into a 2 or more bytelength but whose first byte has - # the high bit set. - } {1} {} - {-nocase 1} {string compare -nocase abcde abdef} {-1} {} - {-nocase 2} {string compare -nocase abcde Abdef} {-1} {} - {-nocase 3} {string compare -nocase abcde ABCDE} {0} {} - {-nocase 4} {string compare -nocase abcde abcde} {0} {} - {-nocase unicode} { - string compare -nocase \334 \u00dc - } 0 {} - {-nocase unicode} { - string compare -nocase \334\334\334\374\u00fc \334\334\334\334\334 - } 0 {} - {-nocase with length} { - string compare -length 2 -nocase abcde Abxyz - } {0} {} - {-nocase with length} { - string compare -nocase -length 3 abcde Abxyz - } {-1} {} - {-nocase with length <= 0} { - string compare -nocase -length -1 abcde AbCdEf - } {-1} {} - {-nocase with excessive length} { - string compare -nocase -length 50 AbCdEf abcde - } {1} {} - {-len unicode} { - # These are strings that are 6 BYTELENGTH long, but the length - # shouldn't make a different because there are actually 3 CHARS long - string compare -len 5 \334\334\334 \334\334\374 - } -1 {} - {-nocase with special index} { - string compare -nocase -length end-3 Abcde abxyz - } {expected integer but got "end-3"} error - {null strings} { - string compare "" "" - } 0 {} - {null strings} { - string compare "" foo - } -1 {} - {null strings} { - string compare foo "" - } 1 {} - {-nocase null strings} { - string compare -nocase "" "" - } 0 {} - {-nocase null strings} { - string compare -nocase "" foo - } -1 {} - {-nocase null strings} { - string compare -nocase foo "" - } 1 {} - {with length, unequal strings} { - string compare -length 2 abc abde - } 0 {} - {with length, unequal strings} { - string compare -length 2 ab abde - } 0 {} - {with NUL character vs. other ASCII} { - # Be careful here, since UTF-8 rep comparison with memcmp() of - # these puts chars in the wrong order - string compare \x00 \x01 - } -1 {} - {high bit} { - string compare "a\x80" "a@" - } 1 {} - {high bit} { - string compare "a\x00" "a\x01" - } -1 {} - {high bit} { - string compare "\x00\x00" "\x00\x01" - } -1 {} - {binary equal} { - string compare [binary format a100 0] [binary format a100 0] - } 0 {} - {binary neq} { - string compare [binary format a100a 0 1] [binary format a100a 0 0] - } 1 {} - {binary neq inequal length} { - string compare [binary format a20a 0 1] [binary format a100a 0 0] - } 1 {} -} { - if {$tname eq ""} { continue } - if {$tcode eq ""} { set tcode ok } - test stringComp-2.[incr i] "string compare, $tname" \ - -body [list eval $tbody] \ - -returnCodes $tcode -result $tresult - test stringComp-2.[incr i] "string compare bc, $tname" \ - -body "[list proc foo {} $tbody];foo" \ - -returnCodes $tcode -result $tresult - if {"error" ni $tcode} { - set tresult [expr {!$tresult}] - } else { - set tresult [string map {compare equal} $tresult] - } - set tbody [string map {compare equal} $tbody] - test stringComp-2.[incr i] "string equal, $tname" \ - -body [list eval $tbody] \ - -returnCodes $tcode -result $tresult - test stringComp-2.[incr i] "string equal bc, $tname" \ - -body "[list proc foo {} $tbody];foo" \ - -returnCodes $tcode -result $tresult -} - -# need a few extra tests short abbr cmd -test stringComp-3.1 {string compare, shortest method name} { - proc foo {} {string co abcde ABCDE} - foo -} 1 -test stringComp-3.2 {string equal, shortest method name} { - proc foo {} {string e abcde ABCDE} - foo -} 0 -test stringComp-3.3 {string equal -nocase} { - proc foo {} {string eq -nocase abcde ABCDE} - foo -} 1 - -test stringComp-4.1 {string first, too few args} { - proc foo {} {string first a} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}} -test stringComp-4.2 {string first, bad args} { - proc foo {} {string first a b c} - list [catch {foo} msg] $msg -} {1 {bad index "c": must be integer?[+-]integer? or end?[+-]integer?}} -test stringComp-4.3 {string first, too many args} { - proc foo {} {string first a b 5 d} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string first needleString haystackString ?startIndex?"}} -test stringComp-4.4 {string first} { - proc foo {} {string first bq abcdefgbcefgbqrs} - foo -} 12 -test stringComp-4.5 {string first} { - proc foo {} {string fir bcd abcdefgbcefgbqrs} - foo -} 1 -test stringComp-4.6 {string first} { - proc foo {} {string f b abcdefgbcefgbqrs} - foo -} 1 -test stringComp-4.7 {string first} { - proc foo {} {string first xxx x123xx345xxx789xxx012} - foo -} 9 -test stringComp-4.8 {string first} { - proc foo {} {string first "" x123xx345xxx789xxx012} - foo -} -1 -test stringComp-4.9 {string first, unicode} { - proc foo {} {string first x abc\u7266x} - foo -} 4 -test stringComp-4.10 {string first, unicode} { - proc foo {} {string first \u7266 abc\u7266x} - foo -} 3 -test stringComp-4.11 {string first, start index} { - proc foo {} {string first \u7266 abc\u7266x 3} - foo -} 3 -test stringComp-4.12 {string first, start index} { - proc foo {} {string first \u7266 abc\u7266x 4} - foo -} -1 -test stringComp-4.13 {string first, start index} { - proc foo {} {string first \u7266 abc\u7266x end-2} - foo -} 3 -test stringComp-4.14 {string first, negative start index} { - proc foo {} {string first b abc -1} - foo -} 1 - -test stringComp-5.1 {string index} { - proc foo {} {string index} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string index string charIndex"}} -test stringComp-5.2 {string index} { - proc foo {} {string index a b c} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string index string charIndex"}} -test stringComp-5.3 {string index} { - proc foo {} {string index abcde 0} - foo -} a -test stringComp-5.4 {string index} { - proc foo {} {string in abcde 4} - foo -} e -test stringComp-5.5 {string index} { - proc foo {} {string index abcde 5} - foo -} {} -test stringComp-5.6 {string index} { - proc foo {} {string index abcde -10} - list [catch {foo} msg] $msg -} {0 {}} -test stringComp-5.7 {string index} { - proc foo {} {string index a xyz} - list [catch {foo} msg] $msg -} {1 {bad index "xyz": must be integer?[+-]integer? or end?[+-]integer?}} -test stringComp-5.8 {string index} { - proc foo {} {string index abc end} - foo -} c -test stringComp-5.9 {string index} { - proc foo {} {string index abc end-1} - foo -} b -test stringComp-5.10 {string index, unicode} { - proc foo {} {string index abc\u7266d 4} - foo -} d -test stringComp-5.11 {string index, unicode} { - proc foo {} {string index abc\u7266d 3} - foo -} \u7266 -test stringComp-5.12 {string index, unicode over char length, under byte length} { - proc foo {} {string index \334\374\334\374 6} - foo -} {} -test stringComp-5.13 {string index, bytearray object} { - proc foo {} {string index [binary format a5 fuz] 0} - foo -} f -test stringComp-5.14 {string index, bytearray object} { - proc foo {} {string index [binary format I* {0x50515253 0x52}] 3} - foo -} S -test stringComp-5.15 {string index, bytearray object} { - proc foo {} { - set b [binary format I* {0x50515253 0x52}] - set i1 [string index $b end-6] - set i2 [string index $b 1] - string compare $i1 $i2 - } - foo -} 0 -test stringComp-5.16 {string index, bytearray object with string obj shimmering} { - proc foo {} { - set str "0123456789\x00 abcdedfghi" - binary scan $str H* dump - string compare [string index $str 10] \x00 - } - foo -} 0 -test stringComp-5.17 {string index, bad integer} -body { - proc foo {} {string index "abc" 0o8} - list [catch {foo} msg] $msg -} -match glob -result {1 {*invalid octal number*}} -test stringComp-5.18 {string index, bad integer} -body { - proc foo {} {string index "abc" end-0o0289} - list [catch {foo} msg] $msg -} -match glob -result {1 {*invalid octal number*}} -test stringComp-5.19 {string index, bytearray object out of bounds} { - proc foo {} {string index [binary format I* {0x50515253 0x52}] -1} - foo -} {} -test stringComp-5.20 {string index, bytearray object out of bounds} { - proc foo {} {string index [binary format I* {0x50515253 0x52}] 20} - foo -} {} - - -proc largest_int {} { - # This will give us what the largest valid int on this machine is, - # so we can test for overflow properly below on >32 bit systems - set int 1 - set exp 7; # assume we get at least 8 bits - while {$int > 0} { set int [expr {1 << [incr exp]}] } - return [expr {$int-1}] -} - -## string is -## not yet bc - -catch {rename largest_int {}} - -## string last -## not yet bc - -## string length -## not yet bc -test stringComp-8.1 {string bytelength} { - proc foo {} {string bytelength} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string bytelength string"}} -test stringComp-8.2 {string bytelength} { - proc foo {} {string bytelength a b} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string bytelength string"}} -test stringComp-8.3 {string bytelength} { - proc foo {} {string bytelength "\u00c7"} - foo -} 2 -test stringComp-8.4 {string bytelength} { - proc foo {} {string b ""} - foo -} 0 - -## string length -## -test stringComp-9.1 {string length} { - proc foo {} {string length} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string length string"}} -test stringComp-9.2 {string length} { - proc foo {} {string length a b} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string length string"}} -test stringComp-9.3 {string length} { - proc foo {} {string length "a little string"} - foo -} 15 -test stringComp-9.4 {string length} { - proc foo {} {string le ""} - foo -} 0 -test stringComp-9.5 {string length, unicode} { - proc foo {} {string le "abcd\u7266"} - foo -} 5 -test stringComp-9.6 {string length, bytearray object} { - proc foo {} {string length [binary format a5 foo]} - foo -} 5 -test stringComp-9.7 {string length, bytearray object} { - proc foo {} {string length [binary format I* {0x50515253 0x52}]} - foo -} 8 - -## string map -## not yet bc - -## string match -## -test stringComp-11.1 {string match, too few args} { - proc foo {} {string match a} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string match ?-nocase? pattern string"}} -test stringComp-11.2 {string match, too many args} { - proc foo {} {string match a b c d} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string match ?-nocase? pattern string"}} -test stringComp-11.3 {string match} { - proc foo {} {string match abc abc} - foo -} 1 -test stringComp-11.4 {string match} { - proc foo {} {string mat abc abd} - foo -} 0 -test stringComp-11.5 {string match} { - proc foo {} {string match ab*c abc} - foo -} 1 -test stringComp-11.6 {string match} { - proc foo {} {string match ab**c abc} - foo -} 1 -test stringComp-11.7 {string match} { - proc foo {} {string match ab* abcdef} - foo -} 1 -test stringComp-11.8 {string match} { - proc foo {} {string match *c abc} - foo -} 1 -test stringComp-11.9 {string match} { - proc foo {} {string match *3*6*9 0123456789} - foo -} 1 -test stringComp-11.10 {string match} { - proc foo {} {string match *3*6*9 01234567890} - foo -} 0 -test stringComp-11.11 {string match} { - proc foo {} {string match a?c abc} - foo -} 1 -test stringComp-11.12 {string match} { - proc foo {} {string match a??c abc} - foo -} 0 -test stringComp-11.13 {string match} { - proc foo {} {string match ?1??4???8? 0123456789} - foo -} 1 -test stringComp-11.14 {string match} { - proc foo {} {string match {[abc]bc} abc} - foo -} 1 -test stringComp-11.15 {string match} { - proc foo {} {string match {a[abc]c} abc} - foo -} 1 -test stringComp-11.16 {string match} { - proc foo {} {string match {a[xyz]c} abc} - foo -} 0 -test stringComp-11.17 {string match} { - proc foo {} {string match {12[2-7]45} 12345} - foo -} 1 -test stringComp-11.18 {string match} { - proc foo {} {string match {12[ab2-4cd]45} 12345} - foo -} 1 -test stringComp-11.19 {string match} { - proc foo {} {string match {12[ab2-4cd]45} 12b45} - foo -} 1 -test stringComp-11.20 {string match} { - proc foo {} {string match {12[ab2-4cd]45} 12d45} - foo -} 1 -test stringComp-11.21 {string match} { - proc foo {} {string match {12[ab2-4cd]45} 12145} - foo -} 0 -test stringComp-11.22 {string match} { - proc foo {} {string match {12[ab2-4cd]45} 12545} - foo -} 0 -test stringComp-11.23 {string match} { - proc foo {} {string match {a\*b} a*b} - foo -} 1 -test stringComp-11.24 {string match} { - proc foo {} {string match {a\*b} ab} - foo -} 0 -test stringComp-11.25 {string match} { - proc foo {} {string match {a\*\?\[\]\\\x} "a*?\[\]\\x"} - foo -} 1 -test stringComp-11.26 {string match} { - proc foo {} {string match ** ""} - foo -} 1 -test stringComp-11.27 {string match} { - proc foo {} {string match *. ""} - foo -} 0 -test stringComp-11.28 {string match} { - proc foo {} {string match "" ""} - foo -} 1 -test stringComp-11.29 {string match} { - proc foo {} {string match \[a a} - foo -} 1 -test stringComp-11.30 {string match, bad args} { - proc foo {} {string match - b c} - list [catch {foo} msg] $msg -} {1 {bad option "-": must be -nocase}} -test stringComp-11.31 {string match case} { - proc foo {} {string match a A} - foo -} 0 -test stringComp-11.32 {string match nocase} { - proc foo {} {string match -n a A} - foo -} 1 -test stringComp-11.33 {string match nocase} { - proc foo {} {string match -nocase a\334 A\374} - foo -} 1 -test stringComp-11.34 {string match nocase} { - proc foo {} {string match -nocase a*f ABCDEf} - foo -} 1 -test stringComp-11.35 {string match case, false hope} { - # This is true because '_' lies between the A-Z and a-z ranges - proc foo {} {string match {[A-z]} _} - foo -} 1 -test stringComp-11.36 {string match nocase range} { - # This is false because although '_' lies between the A-Z and a-z ranges, - # we lower case the end points before checking the ranges. - proc foo {} {string match -nocase {[A-z]} _} - foo -} 0 -test stringComp-11.37 {string match nocase} { - proc foo {} {string match -nocase {[A-fh-Z]} g} - foo -} 0 -test stringComp-11.38 {string match case, reverse range} { - proc foo {} {string match {[A-fh-Z]} g} - foo -} 1 -test stringComp-11.39 {string match, *\ case} { - proc foo {} {string match {*\abc} abc} - foo -} 1 -test stringComp-11.40 {string match, *special case} { - proc foo {} {string match {*[ab]} abc} - foo -} 0 -test stringComp-11.41 {string match, *special case} { - proc foo {} {string match {*[ab]*} abc} - foo -} 1 -test stringComp-11.42 {string match, *special case} { - proc foo {} {string match "*\\" "\\"} - foo -} 0 -test stringComp-11.43 {string match, *special case} { - proc foo {} {string match "*\\\\" "\\"} - foo -} 1 -test stringComp-11.44 {string match, *special case} { - proc foo {} {string match "*???" "12345"} - foo -} 1 -test stringComp-11.45 {string match, *special case} { - proc foo {} {string match "*???" "12"} - foo -} 0 -test stringComp-11.46 {string match, *special case} { - proc foo {} {string match "*\\*" "abc*"} - foo -} 1 -test stringComp-11.47 {string match, *special case} { - proc foo {} {string match "*\\*" "*"} - foo -} 1 -test stringComp-11.48 {string match, *special case} { - proc foo {} {string match "*\\*" "*abc"} - foo -} 0 -test stringComp-11.49 {string match, *special case} { - proc foo {} {string match "?\\*" "a*"} - foo -} 1 -test stringComp-11.50 {string match, *special case} { - proc foo {} {string match "\\" "\\"} - foo -} 0 -test stringComp-11.51 {string match; *, -nocase and UTF-8} { - proc foo {} {string match -nocase [binary format I 717316707] \ - [binary format I 2028036707]} - foo -} 1 -test stringComp-11.52 {string match, null char in string} { - proc foo {} { - set ptn "*abc*" - foreach elem [list "\u0000@abc" "@abc" "\u0000@abc\u0000" "blahabcblah"] { - lappend out [string match $ptn $elem] - } - set out - } - foo -} {1 1 1 1} -test stringComp-11.53 {string match, null char in pattern} { - proc foo {} { - set out "" - foreach {ptn elem} [list \ - "*\u0000abc\u0000" "\u0000abc\u0000" \ - "*\u0000abc\u0000" "\u0000abc\u0000ef" \ - "*\u0000abc\u0000*" "\u0000abc\u0000ef" \ - "*\u0000abc\u0000" "@\u0000abc\u0000ef" \ - "*\u0000abc\u0000*" "@\u0000abc\u0000ef" \ - ] { - lappend out [string match $ptn $elem] - } - set out - } - foo -} {1 0 1 0 1} -test stringComp-11.54 {string match, failure} { - proc foo {} { - set longString "" - for {set i 0} {$i < 10} {incr i} { - append longString "abcdefghijklmnopqrstuvwxy\u0000z01234567890123" - } - list [string match *cba* $longString] \ - [string match *a*l*\u0000* $longString] \ - [string match *a*l*\u0000*123 $longString] \ - [string match *a*l*\u0000*123* $longString] \ - [string match *a*l*\u0000*cba* $longString] \ - [string match *===* $longString] - } - foo -} {0 1 1 1 0 0} - -## string range -test stringComp-12.1 {Bug 3588366: end-offsets before start} { - apply {s { - string range $s 0 end-5 - }} 12345 -} {} - -## string repeat -## not yet bc - -## string replace -test stringComp-14.1 {Bug 82e7f67325} { - apply {x { - set a [join $x {}] - lappend b [string length [string replace ___! 0 2 $a]] - lappend b [string length [string replace ___! 0 2 $a[unset a]]] - }} {a b} -} {3 3} -test stringComp-14.2 {Bug 82e7f67325} memory { - # As in stringComp-14.1, but make sure we don't retain too many refs - leaktest { - apply {x { - set a [join $x {}] - lappend b [string length [string replace ___! 0 2 $a]] - lappend b [string length [string replace ___! 0 2 $a[unset a]]] - }} {a b} - } -} {0} -test stringComp-14.3 {Bug 0dca3bfa8f} { - apply {arg { - set argCopy $arg - set arg [string replace $arg 1 2 aa] - # Crashes in comparison before fix - expr {$arg ne $argCopy} - }} abcde -} 1 -test stringComp-14.4 {Bug 1af8de570511} { - apply {{x y} { - # Generate an unshared string value - set val "" - for { set i 0 } { $i < $x } { incr i } { - set val [format "0%s" $val] - } - string replace $val[unset val] 1 1 $y - }} 4 x -} 0x00 -test stringComp-14.5 {} { - string length [string replace [string repeat a\u00fe 2] 3 end {}] -} 3 - -## string tolower -## not yet bc - -## string toupper -## not yet bc - -## string totitle -## not yet bc - -## string trim* -## not yet bc - -## string word* -## not yet bc - -## string cat -test stringComp-29.1 {string cat, no arg} { - proc foo {} {string cat} - foo -} "" -test stringComp-29.2 {string cat, single arg} { - proc foo {} { - set x FOO - string compare $x [string cat $x] - } - foo -} 0 -test stringComp-29.3 {string cat, two args} { - proc foo {} { - set x FOO - string compare $x$x [string cat $x $x] - } - foo -} 0 -test stringComp-29.4 {string cat, many args} { - proc foo {} { - set x FOO - set n 260 - set xx [string repeat $x $n] - set vv [string repeat {$x} $n] - set vvs [string repeat {$x } $n] - set r1 [string compare $xx [subst $vv]] - set r2 [string compare $xx [eval "string cat $vvs"]] - list $r1 $r2 - } - foo -} {0 0} - - -# cleanup -catch {rename foo {}} -::tcltest::cleanupTests -return - -# Local Variables: -# mode: tcl -# End: diff --git a/tests/stringObj.test b/tests/stringObj.test index 8209142..a78b5f8 100644 --- a/tests/stringObj.test +++ b/tests/stringObj.test @@ -414,10 +414,10 @@ test stringObj-13.3 {Tcl_GetCharLength with byte-size chars} testobj { list [string length $a] [string length $a] } {6 6} test stringObj-13.4 {Tcl_GetCharLength with mixed width chars} testobj { - string length "\u00ae" + string length "\u00ae" } 1 test stringObj-13.5 {Tcl_GetCharLength with mixed width chars} testobj { - # string length "￮￮" + # string length "￮￮" # Use \uXXXX notation below instead of hardcoding the values, otherwise # the test will fail in multibyte locales. string length "\u00EF\u00BF\u00AE\u00EF\u00BF\u00AE" @@ -480,7 +480,6 @@ test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 3 } foo - if {[testConstraint testobj]} { testobj freeallvars @@ -489,3 +488,7 @@ if {[testConstraint testobj]} { # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/subst.test b/tests/subst.test index 2115772..1f3c22a 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -91,29 +91,29 @@ test subst-5.4 {command substitutions} { } {1 {invalid command name "bogus_command"}} test subst-5.5 {command substitutions} { set a 0 - list [catch {subst {[set a 1}} msg] $a $msg + list [catch {subst {[set a 1}} msg] $a $msg } {1 0 {missing close-bracket}} test subst-5.6 {command substitutions} { set a 0 - list [catch {subst {0[set a 1}} msg] $a $msg + list [catch {subst {0[set a 1}} msg] $a $msg } {1 0 {missing close-bracket}} test subst-5.7 {command substitutions} { set a 0 - list [catch {subst {0[set a 1; set a 2}} msg] $a $msg + list [catch {subst {0[set a 1; set a 2}} msg] $a $msg } {1 1 {missing close-bracket}} # repeat the tests above simulating cmd line input test subst-5.8 {command substitutions} { set script {[subst {[set a 1}]} - list [catch {exec [info nameofexecutable] << $script} msg] $msg + list [catch {exec [info nameofexecutable] << $script} msg] $msg } {1 {missing close-bracket}} test subst-5.9 {command substitutions} { set script {[subst {0[set a 1}]} - list [catch {exec [info nameofexecutable] << $script} msg] $msg + list [catch {exec [info nameofexecutable] << $script} msg] $msg } {1 {missing close-bracket}} test subst-5.10 {command substitutions} { set script {[subst {0[set a 1; set a 2}]} - list [catch {exec [info nameofexecutable] << $script} msg] $msg + list [catch {exec [info nameofexecutable] << $script} msg] $msg } {1 {missing close-bracket}} test subst-6.1 {clear the result after command substitution} -body { @@ -166,7 +166,7 @@ test subst-8.6 {return in a subst} -returnCodes error -body { subst "foo \[return {x}; bogus code bar" } -result {missing close-bracket} test subst-8.7 {return in a subst, parse error} -body { - subst {foo [return {x} ; set a {}"" ; stuff] bar} + subst {foo [return {x} ; set a {}"" ; stuff] bar} } -returnCodes error -result {extra characters after close-brace} test subst-8.8 {return in a subst, parse error} -body { subst {foo [return {x} ; set bar baz ; set a {}"" ; stuff] bar} diff --git a/tests/tailcall.test b/tests/tailcall.test index 26f3cbf..9174167 100644 --- a/tests/tailcall.test +++ b/tests/tailcall.test @@ -28,9 +28,9 @@ if {[testConstraint testnrelevels]} { namespace eval testnre { # # [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels, - # cmdFrame level, callFrame level, tosPtr and callback depth + # cmdFrame level, callFrame level, tosPtr and callback depth # - variable last [testnrelevels] + variable last [testnrelevels] proc depthDiff {} { variable last set depth [testnrelevels] @@ -148,7 +148,7 @@ test tailcall-0.5 {tailcall is constant space} -constraints testnrelevels -setup } -result {0 0 0 0 0 0} test tailcall-0.5.1 {tailcall is constant space} -constraints testnrelevels -setup { - # + # # This test is related to [bug d87cb182053fd79b3]: the fix to that bug was # to remove a call to TclSkipTailcall, which caused a violation of the # constant-space property of tailcall in that particular @@ -245,7 +245,7 @@ test tailcall-1 {tailcall} -body { } variable x *:: proc xset args {error ::xset} - list [::b::moo] | $x $a::x $b::x | $::b::y + list [::b::moo] | $x $a::x $b::x | $::b::y } -cleanup { unset x rename xset {} @@ -619,7 +619,7 @@ test tailcall-12.3a3 {[Bug 2695587]} -body { set x } -cleanup { unset x -} -result {0 1} +} -result {0 1} test tailcall-12.3b0 {[Bug 2695587]} -body { apply {{} { @@ -654,7 +654,7 @@ test tailcall-12.3b3 {[Bug 2695587]} -body { set x } -cleanup { unset x -} -result {0 1} +} -result {0 1} # MORE VARIANTS MISSING: bc'ed caught script vs (bc'ed, not-bc'ed) # catch. Actually superfluous now, as tailcall just returns TCL_RETURN so that @@ -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 728a018..ca720ee 100644..100755 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -550,6 +550,7 @@ switch -- $::tcl_platform(platform) { file attributes $notWriteableDir -permissions 00555 } default { + # note in FAT/NTFS we won't be able to protect directory with read-only attribute... catch {file attributes $notWriteableDir -readonly 1} catch {testchmod 0 $notWriteableDir} } @@ -566,9 +567,10 @@ test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} { # This constraint doesn't go at the top of the file so that it doesn't # interfere with tcltest-5.5 testConstraint notFAT [expr { - ![string match "FAT*" [lindex [file system $notWriteableDir] 1]] + ![regexp {^(FAT\d*|NTFS)$} [lindex [file system $notWriteableDir] 1]] + || $::tcl_platform(platform) eq "unix" || [llength [info commands testchmod]] }] -# FAT permissions are fairly hopeless; ignore this test if that FS is used +# FAT/NTFS permissions are fairly hopeless; ignore this test if that FS is used test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} { -constraints {unixOrPc notRoot notFAT} -body { @@ -906,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 } @@ -918,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 } } @@ -1198,7 +1207,7 @@ test tcltest-21.2 {force a test command failure} { } {1} } -returnCodes 1 - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } test tcltest-21.3 {test command with setup} { @@ -1291,7 +1300,7 @@ test tcltest-21.7 {test command - bad flag} { } } -returnCodes 1 - -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} } # alternate test command format (these are the same as 21.1-21.6, with the @@ -1311,7 +1320,7 @@ test tcltest-21.8 {force a test command failure} \ } \ -returnCodes 1 \ -cleanup {set ::tcltest::currentFailure $fail} \ - -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup} + -result {bad option "1": must be -body, -cleanup, -constraints, -errorCode, -errorOutput, -match, -output, -result, -returnCodes, or -setup} test tcltest-21.9 {test command with setup} \ -setup {set foo 1} \ 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/trace.test b/tests/trace.test index d830f3c..1099f48 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -164,30 +164,30 @@ test trace-1.10 {trace variable reads} { } {} test trace-1.11 {read traces that modify the array structure} { unset -nocomplain x - set x(bar) 0 - trace variable x r {set x(foo) 1 ;#} - trace variable x r {unset -nocomplain x(bar) ;#} + set x(bar) 0 + trace variable x r {set x(foo) 1 ;#} + trace variable x r {unset -nocomplain x(bar) ;#} array get x } {} test trace-1.12 {read traces that modify the array structure} { unset -nocomplain x - set x(bar) 0 - trace variable x r {unset -nocomplain x(bar) ;#} - trace variable x r {set x(foo) 1 ;#} + set x(bar) 0 + trace variable x r {unset -nocomplain x(bar) ;#} + trace variable x r {set x(foo) 1 ;#} array get x } {} test trace-1.13 {read traces that modify the array structure} { unset -nocomplain x - set x(bar) 0 - trace variable x r {set x(foo) 1 ;#} - trace variable x r {unset -nocomplain x;#} + set x(bar) 0 + trace variable x r {set x(foo) 1 ;#} + trace variable x r {unset -nocomplain x;#} list [catch {array get x} res] $res } {1 {can't read "x(bar)": no such variable}} test trace-1.14 {read traces that modify the array structure} { unset -nocomplain x - set x(bar) 0 - trace variable x r {unset -nocomplain x;#} - trace variable x r {set x(foo) 1 ;#} + set x(bar) 0 + trace variable x r {unset -nocomplain x;#} + trace variable x r {set x(foo) 1 ;#} list [catch {array get x} res] $res } {1 {can't read "x(bar)": no such variable}} @@ -419,7 +419,7 @@ test trace-5.8 {array traces fire for undefined variables} { trace add variable x array {set x(foo) 1 ;#} set res "names: [array names x]" } {names: foo} - + # Trace multiple trace types at once. test trace-6.1 {multiple ops traced at once} { @@ -767,7 +767,7 @@ test trace-13.1 {delete one trace from another} { trace add variable x read {traceTag 2} trace add variable x read {traceTag 3} trace add variable x read {traceTag 4} - trace add variable x read delTraces + trace add variable x read delTraces trace add variable x read {traceTag 5} set x set info @@ -872,7 +872,7 @@ test trace-14.5 {trace command, invalid option} { } [list 1 "bad option \"gorp\": must be add, info, remove, variable, vdelete, or vinfo"] # Again, [trace ... command] and [trace ... variable] share syntax and -# error message styles for their opList options; these loops test those +# error message styles for their opList options; these loops test those # error messages. set i 0 @@ -2104,7 +2104,7 @@ foo foo 0 1 leave} test trace-28.2 {exec traces with 'error'} { set info {} set res {} - + proc foo {} { if {[catch {bar}]} { return "error" @@ -2126,7 +2126,7 @@ test trace-28.2 {exec traces with 'error'} { trace remove execution foo {enter enterstep leave leavestep} \ [list traceExecute foo] - + list $res [join $info \n] } {{error error} {foo foo enter foo {if {[catch {bar}]} { @@ -2152,7 +2152,7 @@ foo foo 0 error leave}} test trace-28.3 {exec traces with 'return -code error'} { set info {} set res {} - + proc foo {} { if {[catch {bar}]} { return "error" @@ -2174,7 +2174,7 @@ test trace-28.3 {exec traces with 'return -code error'} { trace remove execution foo {enter enterstep leave leavestep} \ [list traceExecute foo] - + list $res [join $info \n] } {{error error} {foo foo enter foo {if {[catch {bar}]} { @@ -2204,7 +2204,7 @@ test trace-28.4 {exec traces in slave with 'return -code error'} { set res [interp eval slave { set info {} set res {} - + proc foo {} { if {[catch {bar}]} { return "error" @@ -2212,21 +2212,21 @@ test trace-28.4 {exec traces in slave with 'return -code error'} { return "ok" } } - + proc bar {} { return -code error "msg" } - + lappend res [foo] - + trace add execution foo {enter enterstep leave leavestep} \ [list traceExecute foo] - + # With the trace active - + lappend res [foo] - + trace remove execution foo {enter enterstep leave leavestep} \ [list traceExecute foo] - + list $res }] interp delete slave @@ -2610,7 +2610,7 @@ test trace-39 {bug #3484621: tracing Bc'ed commands} -setup { proc foo {} { incr ::traceCalls # choose a BC'ed command that is 'unlikely' to interfere with tcltest's - # internals + # internals lset ::bar 1 2 } } -body { @@ -2631,7 +2631,7 @@ test trace-39 {bug #3484621: tracing Bc'ed commands} -setup { rename dotrace {} rename foo {} } -result {3 | 0 1 1} - + test trace-39.1 {bug #3485022: tracing Bc'ed commands} -setup { set ::traceLog 0 set ::traceCalls 0 @@ -2668,7 +2668,7 @@ test trace-40.1 {execution trace errors become command errors} { catch foo m return -level 0 $m[unset m] } bar - + # Delete procedures when done, so we don't clash with other tests # (e.g. foobar will clash with 'unknown' tests). catch {rename foobar {}} diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test index 183c145..08eb664 100644 --- a/tests/unixFCmd.test +++ b/tests/unixFCmd.test @@ -221,12 +221,12 @@ test unixFCmd-2.5 {TclpCopyFile: copy attributes} -setup { cleanup } -constraints {unix notRoot} -body { close [open tf1 a] - file attributes tf1 -permissions 0472 + file attributes tf1 -permissions 0o472 file copy tf1 tf2 file attributes tf2 -permissions } -cleanup { cleanup -} -result 00472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w- +} -result 0o472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w- test unixFCmd-3.1 {CopyFile not done} {emptyTest unix notRoot} { } {} @@ -375,11 +375,11 @@ proc permcheck {testnum permList expected} { set result } $expected } -permcheck unixFCmd-17.5 rwxrwxrwx 00777 -permcheck unixFCmd-17.6 r--r---w- 00442 -permcheck unixFCmd-17.7 {0 u+rwx,g+r u-w o+rwx} {00000 00740 00540 00547} -permcheck unixFCmd-17.11 --x--x--x 00111 -permcheck unixFCmd-17.12 {0 a+rwx} {00000 00777} +permcheck unixFCmd-17.5 rwxrwxrwx 0o777 +permcheck unixFCmd-17.6 r--r---w- 0o442 +permcheck unixFCmd-17.7 {0 u+rwx,g+r u-w o+rwx} {00000 0o740 0o540 0o547} +permcheck unixFCmd-17.11 --x--x--x 0o111 +permcheck unixFCmd-17.12 {0 a+rwx} {00000 0o777} file delete -force -- foo.test test unixFCmd-18.1 {Unix pwd} -constraints {unix notRoot nonPortable} -setup { diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test index 120f362..d7b86fd 100644 --- a/tests/unixForkEvent.test +++ b/tests/unixForkEvent.test @@ -37,7 +37,7 @@ test unixforkevent-1.1 {fork and test writeable event} \ viewFile result.txt $myFolder } \ -result {writable} \ - -cleanup { + -cleanup { catch { removeFolder $myFolder } } diff --git a/tests/unixInit.test b/tests/unixInit.test index 05338ed..0469ee8 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.test @@ -15,6 +15,9 @@ namespace import ::tcltest::* unset -nocomplain path catch {set oldlang $env(LANG)} set env(LANG) C + +# Some tests require the testgetencpath command +testConstraint testgetencpath [llength [info commands testgetencpath]] test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unix stdio} { set x {} @@ -87,13 +90,15 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio} skip [concat [skip] unixInit-2.*] -test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} { - set origDir [testgetdefenc] - testsetdefenc slappy - set path [testgetdefenc] - testsetdefenc $origDir +test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} -constraints { + testgetencpath +} -body { + set origPath [testgetencpath] + testsetencpath slappy + set path [testgetencpath] + testsetencpath $origPath set path -} {slappy} +} -result {slappy} test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} -setup { unset -nocomplain oldlibrary if {[info exists env(TCL_LIBRARY)]} { diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test index 2f03529..0bd8c69 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.test @@ -18,27 +18,22 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # When run in a Tk shell, these tests hang. testConstraint noTk [expr {0 != [catch {package present Tk}]}] testConstraint thread [expr {0 == [catch {package require Thread 2.7-}]}] -# Darwin always uses a threaded notifier -testConstraint unthreaded [expr { - ![::tcl::pkgconfig get threaded] - && $tcl_platform(os) ne "Darwin" -}] # The next two tests will hang if threads are enabled because the notifier # will not necessarily wait for ever in this case, so it does not generate # an error. -test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -body { +test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints nonPortable -body { catch {vwait x} set f [open [makeFile "" foo] w] fileevent $f writable {set x 1} vwait x close $f list [catch {vwait x} msg] $msg -} -result {1 {can't wait for variable "x": would wait forever}} -cleanup { +} -result {1 {can't wait for variable "x": would wait forever}} -cleanup { catch { close $f } catch { removeFile foo } } -test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -body { +test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints nonPortable -body { catch {vwait x} set f1 [open [makeFile "" foo] w] set f2 [open [makeFile "" foo2] w] @@ -90,7 +85,7 @@ test unixNotfy-2.2 {Tcl_DeleteFileHandler} \ set x } \ -result {ok} \ - -cleanup { + -cleanup { catch { close $f1 } catch { close $f2 } catch { removeFile foo } diff --git a/tests/unknown.test b/tests/unknown.test index e80d3a6..6c31c3d 100644 --- a/tests/unknown.test +++ b/tests/unknown.test @@ -58,7 +58,7 @@ test unknown-4.1 {errors in "unknown" procedure} { catch {rename unknown {}} catch {rename unknown.old unknown} cleanupTests -return +return # Local Variables: # mode: tcl diff --git a/tests/uplevel.test b/tests/uplevel.test index 9ecc0d5..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"} @@ -237,7 +237,7 @@ test uplevel-7.1 {var access, no LVT in either level} -setup { unset -nocomplain y z } -body { namespace eval foo { - set x 2 + set x 2 set y 2 uplevel 1 { set x 3 @@ -256,7 +256,7 @@ test uplevel-7.2 {var access, no LVT in upper level} -setup { unset -nocomplain y z } -body { proc foo {} { - set x 2 + set x 2 set y 2 uplevel 1 { set x 3 @@ -280,7 +280,7 @@ test uplevel-7.3 {var access, LVT in upper level} -setup { } } -body { proc foo {} { - set x 2 + set x 2 set y 2 uplevel 1 { set x 3 diff --git a/tests/upvar.test b/tests/upvar.test index 5ea870d..476250c 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -477,7 +477,7 @@ test upvar-NS-1.4 {nsupvar links to correct variable} -body { } -returnCodes error -cleanup { namespace delete test_ns_1 } -result {namespace "test_ns_0" not found in "::test_ns_1"} - + test upvar-NS-1.5 {nsupvar links to correct variable} -body { namespace eval test_ns_1 { namespace eval test_ns_0 {} diff --git a/tests/utf.test b/tests/utf.test index 95775a8..e820359 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -21,7 +21,7 @@ testConstraint testbytestring [llength [info commands testbytestring]] catch {unset x} # Some tests require support for 4-byte UTF-8 sequences -testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}] +testConstraint tip389 [expr {[string length \U010000] == 2}] test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} testbytestring { expr {"\x01" eq [testbytestring "\x01"]} @@ -41,9 +41,21 @@ test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring { test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring { expr {[format %c -1] eq [testbytestring "\xef\xbf\xbd"]} } 1 -test utf-1.7 {Tcl_UniCharToUtf: 4 byte sequences} -constraints {fullutf testbytestring} -body { +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" @@ -66,10 +78,10 @@ test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestrin test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring { string length [testbytestring "\xE4\xb9\x8e"] } {1} -test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body { +test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {tip389 testbytestring} -body { string length [testbytestring "\xF0\x90\x80\x80"] } -result {2} -test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body { +test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {tip389 testbytestring} -body { string length [testbytestring "\xF4\x8F\xBF\xBF"] } -result {2} test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring { @@ -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 @@ -228,15 +246,13 @@ bsCheck \U4e21 20001 bsCheck \U004e21 20001 bsCheck \U00004e21 20001 bsCheck \U0000004e21 78 -if {[testConstraint fullutf]} { - bsCheck \U00110000 69632 - bsCheck \U01100000 69632 - bsCheck \U11000000 69632 - bsCheck \U0010FFFF 1114111 - bsCheck \U010FFFF0 1114111 - bsCheck \U10FFFF00 1114111 - bsCheck \UFFFFFFFF 1048575 -} +bsCheck \U00110000 69632 +bsCheck \U01100000 69632 +bsCheck \U11000000 69632 +bsCheck \U0010FFFF 1114111 +bsCheck \U010FFFF0 1114111 +bsCheck \U10FFFF00 1114111 +bsCheck \UFFFFFFFF 1048575 test utf-11.1 {Tcl_UtfToUpper} { string toupper {} @@ -250,6 +266,12 @@ test utf-11.3 {Tcl_UtfToUpper} { test utf-11.4 {Tcl_UtfToUpper} { string toupper \u01e3ab } \u01e2AB +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 {} @@ -263,6 +285,12 @@ test utf-12.3 {Tcl_UtfToLower} { test utf-12.4 {Tcl_UtfToLower} { string tolower \u01e2AB } \u01e3ab +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 {} @@ -276,6 +304,15 @@ test utf-13.3 {Tcl_UtfToTitle} { test utf-13.4 {Tcl_UtfToTitle} { string totitle \u01f3ab } \u01f2ab +test utf-13.5 {Tcl_UtfToTitle Georgian (new in Unicode 11)} { + string totitle \u10d0\u1c90 +} \u10d0\u1c90 +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 2ac11bf..5079a89 100644 --- a/tests/util.test +++ b/tests/util.test @@ -20,6 +20,7 @@ testConstraint testbytestring [llength [info commands testbytestring]] testConstraint testdstring [llength [info commands testdstring]] testConstraint testconcatobj [llength [info commands testconcatobj]] testConstraint testdoubledigits [llength [info commands testdoubledigits]] +testConstraint testprint [llength [info commands testprint]] # Big test for correct ordering of data in [expr] @@ -552,6 +553,12 @@ test util-9.0.6 {TclGetIntForIndex} { test util-9.0.7 {TclGetIntForIndex} { string index abcd { 01 } } b +test util-9.0.8 {TclGetIntForIndex} { + string index abcd { 0d0 } +} a +test util-9.0.9 {TclGetIntForIndex} { + string index abcd { -0d0 } +} a test util-9.1.0 {TclGetIntForIndex} { string index abcd 3 } d @@ -564,6 +571,12 @@ test util-9.1.2 {TclGetIntForIndex} { test util-9.1.3 {TclGetIntForIndex} { string index abcdefghijk { 0xa } } k +test util-9.1.4 {TclGetIntForIndex} { + string index abcdefghijk 0d10 +} k +test util-9.1.5 {TclGetIntForIndex} { + string index abcdefghijk { 0d10 } +} k test util-9.2.0 {TclGetIntForIndex} { string index abcd end } d @@ -573,14 +586,14 @@ test util-9.2.1 {TclGetIntForIndex} -body { test util-9.2.2 {TclGetIntForIndex} -body { string index abcd {end } } -returnCodes error -match glob -result * -test util-9.3 {TclGetIntForIndex} { +test util-9.3 {TclGetIntForIndex} -body { # Deprecated string index abcd en -} d -test util-9.4 {TclGetIntForIndex} { +} -returnCodes error -match glob -result * +test util-9.4 {TclGetIntForIndex} -body { # Deprecated string index abcd e -} d +} -returnCodes error -match glob -result * test util-9.5.0 {TclGetIntForIndex} { string index abcd end-1 } c @@ -671,12 +684,18 @@ test util-9.30 {TclGetIntForIndex} -body { test util-9.31 {TclGetIntForIndex} -body { string index a 0x } -returnCodes error -match glob -result * +test util-9.31.1 {TclGetIntForIndex} -body { + string index a 0d +} -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 +} -result {} test util-9.34 {TclGetIntForIndex} -body { string index a 1.0 } -returnCodes error -match glob -result * @@ -709,7 +728,50 @@ test util-9.43 {TclGetIntForIndex} -body { } -returnCodes error -match glob -result * test util-9.44 {TclGetIntForIndex} -body { string index a 0+1000000000000 +} -result {} +test util-9.45 {TclGetIntForIndex} { + string index abcd end+2305843009213693950 +} {} +test util-9.46 {TclGetIntForIndex} { + string index abcd end+4294967294 +} {} +# TIP 502 +test util-9.47 {TclGetIntForIndex} { + string index abcd 0x10000000000000000 +} {} +test util-9.48 {TclGetIntForIndex} { + string index abcd -0x10000000000000000 +} {} +test util-9.49 {TclGetIntForIndex} -body { + string index abcd end*1 +} -returnCodes error -match glob -result * +test util-9.50 {TclGetIntForIndex} -body { + string index abcd {end- 1} +} -returnCodes error -match glob -result * +test util-9.51 {TclGetIntForIndex} -body { + string index abcd end-end +} -returnCodes error -match glob -result * +test util-9.52 {TclGetIntForIndex} -body { + string index abcd end-x } -returnCodes error -match glob -result * +test util-9.53 {TclGetIntForIndex} -body { + string index abcd end-0.1 +} -returnCodes error -match glob -result * +test util-9.54 {TclGetIntForIndex} { + string index abcd end-0x10000000000000000 +} {} +test util-9.55 {TclGetIntForIndex} { + string index abcd end+0x10000000000000000 +} {} +test util-9.56 {TclGetIntForIndex} { + string index abcd end--0x10000000000000000 +} {} +test util-9.57 {TclGetIntForIndex} { + string index abcd end+-0x10000000000000000 +} {} +test util-9.58 {TclGetIntForIndex} { + string index abcd end--0x8000000000000000 +} {} test util-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} { convertDouble 0x0000000000000000 @@ -4017,6 +4079,54 @@ test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} { 0x4400000000000000 0xc400000000000000 }] +test util-18.1 {Tcl_ObjPrintf} {testprint} { + testprint %lld [expr 2**63-1] +} {9223372036854775807} + +test util-18.2 {Tcl_ObjPrintf} {testprint} { + testprint %I64d [expr 2**63-1] +} {9223372036854775807} + +test util-18.3 {Tcl_ObjPrintf} {testprint} { + testprint %qd [expr 2**63-1] +} {9223372036854775807} + +test util-18.4 {Tcl_ObjPrintf} {testprint} { + testprint %jd [expr 2**63-1] +} {9223372036854775807} + +test util-18.5 {Tcl_ObjPrintf} {testprint} { + testprint %lld [expr -2**63] +} {-9223372036854775808} + +test util-18.6 {Tcl_ObjPrintf} {testprint} { + testprint %I64d [expr -2**63] +} {-9223372036854775808} + +test util-18.7 {Tcl_ObjPrintf} {testprint} { + testprint %qd [expr -2**63] +} {-9223372036854775808} + +test util-18.8 {Tcl_ObjPrintf} {testprint} { + testprint %jd [expr -2**63] +} {-9223372036854775808} + +test util-18.9 {Tcl_ObjPrintf} {testprint} { + testprint "%I64d %I32d" [expr -2**63+2] +} {-9223372036854775806 2} + +test util-18.10 {Tcl_ObjPrintf} {testprint} { + testprint "%I64d %p" 65535 +} {65535 0xffff} + +test util-18.11 {Tcl_ObjPrintf} {testprint} { + testprint "%I64d %td" 65536 +} {65536 65536} + +test util-18.12 {Tcl_ObjPrintf} {testprint} { + testprint "%I64d %Id" 65537 +} {65537 65537} + set ::tcl_precision $saved_precision # cleanup diff --git a/tests/var.test b/tests/var.test index a9d93ac..36beb3a 100644 --- a/tests/var.test +++ b/tests/var.test @@ -41,6 +41,7 @@ if {[testConstraint memory]} { } } + catch {rename p ""} catch {namespace delete test_ns_var} catch {unset xx} @@ -53,7 +54,7 @@ catch {unset arr} test var-1.1 {TclLookupVar, Array handling} -setup { catch {unset a} } -body { - set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd + set x "incr" ;# force no compilation and runtime call to Tcl_IncrCmd set i 10 set arr(foo) 37 list [$x i] $i [$x arr(foo)] $arr(foo) @@ -234,7 +235,7 @@ test var-3.3 {MakeUpvar, my var has TCL_GLOBAL_ONLY specified} -setup { set a 123321 proc p {} { # create global xx linked to global a - testupvar 1 a {} xx global + testupvar 1 a {} xx global } list [p] $xx [set xx 789] $a } -result {{} 123321 789 789} @@ -246,7 +247,7 @@ test var-3.4 {MakeUpvar, my var has TCL_NAMESPACE_ONLY specified} -setup { catch {unset ::test_ns_var::vv} proc p {} { # create namespace var vv linked to global a - testupvar 1 a {} vv namespace + testupvar 1 a {} vv namespace } p } @@ -548,11 +549,11 @@ test var-7.14 {Tcl_VariableObjCmd, array element parameter} -body { namespace eval test_ns_var { variable arrayvar(1) } } -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array" test var-7.15 {Tcl_VariableObjCmd, array element parameter} -body { - namespace eval test_ns_var { + namespace eval test_ns_var { variable arrayvar set arrayvar(1) x variable arrayvar(1) y - } + } } -returnCodes error -result "can't define \"arrayvar(1)\": name refers to an element in an array" test var-7.16 {Tcl_VariableObjCmd, no args (TIP 323)} { variable @@ -776,6 +777,22 @@ test var-13.1 {Tcl_UnsetVar2, unset array with trace set on element} -setup { } set x "If you see this, it worked" } -result "If you see this, it worked" +test var-13.2 {unset array with search, bug 46a2410650} -body { + apply {{} { + array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66} + set s [array startsearch a] + unset a([array nextelement a $s]) + array nextelement a $s + }} +} -returnCodes error -result {couldn't find search "s-1-a"} +test var-13.3 {unset array with search, SIGSEGV, bug 46a2410650} -body { + apply {{} { + array set a {aa 11 bb 22 cc 33 dd 44 ee 55 ff 66} + set s [array startsearch a] + unset a(ff) + array nextelement a $s + }} +} -returnCodes error -result {couldn't find search "s-1-a"} test var-14.1 {array names syntax} -body { array names foo bar baz snafu @@ -790,7 +807,7 @@ test var-15.1 {segfault in [unset], [Bug 735335]} { set var $name } # - # Note that the variable name has to be + # Note that the variable name has to be # unused previously for the segfault to # be triggered. # @@ -819,6 +836,18 @@ test var-17.1 {TclArraySet [Bug 1669489]} -setup { } -cleanup { unset -nocomplain ::a ::elements } -result {} +test var-17.2 {TclArraySet Dict shortcut only on pure value} -setup { + unset -nocomplain a d + set d {p 1 p 2} + dict get $d p + set foo 0 +} -body { + trace add variable a write "[list incr [namespace which -variable foo]];#" + array set a $d + set foo +} -cleanup { + unset -nocomplain a d foo +} -result 2 test var-18.1 {array unset and unset traces: Bug 2939073} -setup { set already 0 @@ -930,6 +959,28 @@ test var-20.9 {[bc1a96407a] array set compiled w/ trace} -setup { test var-20.10 {[bc1a96407a] array set don't compile bad varname} -body { apply {{} {set name foo(bar); array set $name {a 1}}} } -returnCodes error -match glob -result * +test var-20.11 {array set don't compile bad initializer} -setup { + unset -nocomplain foo + trace add variable foo array {set foo(bar) baz;#} +} -body { + catch {array set foo bad} + set foo(bar) +} -cleanup { + unset -nocomplain foo +} -result baz +test var-20.12 {array set don't compile bad initializer} -setup { + unset -nocomplain ::foo + trace add variable ::foo array {set ::foo(bar) baz;#} +} -body { + catch {apply {{} { + set value bad + array set ::foo $value + + }}} + set ::foo(bar) +} -cleanup { + unset -nocomplain ::foo +} -result baz test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup { proc linenumber {} {dict get [info frame -1] line} @@ -944,9 +995,6 @@ test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup { } -result 1 test var-22.0 {leak in array element unset: Bug a3309d01db} -setup { - proc getbytes {} { - lindex [split [memory info] \n] 3 3 - } proc doit k { variable A set A($k) {} @@ -966,13 +1014,9 @@ test var-22.0 {leak in array element unset: Bug a3309d01db} -setup { set leakedBytes [expr {$end - $tmp}] } -cleanup { array unset A - rename getbytes {} rename doit {} } -result 0 test var-22.1 {leak in localVarName intrep: Bug 80304238ac} -setup { - proc getbytes {} { - lindex [split [memory info] \n] 3 3 - } proc doit {} { interp create slave slave eval { @@ -994,15 +1038,431 @@ test var-22.1 {leak in localVarName intrep: Bug 80304238ac} -setup { set leakedBytes [expr {$end - $tmp}] } -cleanup { array unset A - rename getbytes {} rename doit {} } -result 0 +test var-22.2 {leak in parsedVarName} -constraints memory -body { + set i 0 + leaktest {lappend x($i)} +} -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 {} +} -result {wrong # args: should be "array for {key value} arrayName script"} +test var-23.2 {array command, for loop, not enough args} -returnCodes error -body { + array for {k v} {} +} -result {wrong # args: should be "array for {key value} arrayName script"} +test var-23.3 {array command, for loop, too many list args} -setup { + unset -nocomplain a +} -returnCodes error -body { + array for {k v w} a {} +} -result {must have two variable names} +test var-23.4 {array command, for loop, not enough list args} -setup { + unset -nocomplain a +} -returnCodes error -body { + array for {k} a {} +} -result {must have two variable names} +test var-23.5 {array command, for loop, no array} -setup { + unset -nocomplain a +} -returnCodes error -body { + array for {k v} a {} +} -result {"a" isn't an array} +test var-23.6 {array command, for loop, array doesn't exist yet but has compiler-allocated procedure slot} -setup { + catch {rename p ""} +} -returnCodes error -body { + apply {{x} { + if {$x==1} { + return [array for {k v} a {}] + } + set a(x) 123 + }} 1 +} -result {"a" isn't an array} +test var-23.7 {array enumeration} -setup { + unset -nocomplain a + set reslist [list] +} -body { + array set a {a 1 b 2 c 3} + array for {k v} a { + lappend reslist $k $v + } + lsort -stride 2 -index 0 $reslist +} -cleanup { + unset -nocomplain a + unset -nocomplain reslist +} -result {a 1 b 2 c 3} +test var-23.9 {array enumeration, nested} -setup { + unset -nocomplain a + set reslist [list] +} -body { + array set a {a 1 b 2 c 3} + array for {k1 v1} a { + lappend reslist $k1 $v1 + set r2 {} + array for {k2 v2} a { + lappend r2 $k2 $v2 + } + lappend reslist [lsort -stride 2 -index 0 $r2] + } + # there is no guarantee in which order the array contents will be + # returned. + lsort -stride 3 -index 0 $reslist +} -cleanup { + unset -nocomplain a + unset -nocomplain reslist +} -result {a 1 {a 1 b 2 c 3} b 2 {a 1 b 2 c 3} c 3 {a 1 b 2 c 3}} +test var-23.10 {array enumeration, delete key} -match glob -setup { + unset -nocomplain a + set reslist [list] +} -body { + set retval {} + try { + array set a {a 1 b 2 c 3 d 4} + array for {k v} a { + lappend reslist $k $v + if { $k eq "a" } { + unset a(c) + } + } + lsort -stride 2 -index 0 $reslist + } on error {err res} { + set retval [dict get $res -errorinfo] + } + set retval +} -cleanup { + unset -nocomplain a + unset -nocomplain reslist + unset -nocomplain retval +} -result {array changed during iteration*} +test var-23.11 {array enumeration, insert key} -match glob -setup { + unset -nocomplain a + set reslist [list] +} -body { + set retval {} + try { + array set a {a 1 b 2 c 3 d 4} + array for {k v} a { + lappend reslist $k $v + if { $k eq "a" } { + set a(e) 5 + } + } + lsort -stride 2 -index 0 $reslist + } on error {err res} { + set retval [dict get $res -errorinfo] + } +} -cleanup { + unset -nocomplain a + unset -nocomplain reslist +} -result {array changed during iteration*} +test var-23.12 {array enumeration, change value} -setup { + unset -nocomplain a + set reslist [list] +} -body { + array set a {a 1 b 2 c 3} + array for {k v} a { + lappend reslist $k $v + if { $k eq "a" } { + set a(c) 9 + } + } + lsort -stride 2 -index 0 $reslist +} -cleanup { + unset -nocomplain a + unset -nocomplain reslist +} -result {a 1 b 2 c 9} +test var-23.13 {array enumeration, number of traces} -setup { + set ::countarrayfor 0 + proc ::tracearrayfor { args } { + incr ::countarrayfor + } + unset -nocomplain ::a + set reslist [list] +} -body { + array set ::a {a 1 b 2 c 3} + foreach {k} [array names a] { + trace add variable ::a($k) read ::tracearrayfor + } + array for {k v} ::a { + lappend reslist $k $v + } + set ::countarrayfor +} -cleanup { + unset -nocomplain ::countarrayfor + unset -nocomplain ::a + unset -nocomplain reslist +} -result 3 +test var-23.14 {array for, shared arguments} -setup { + set vn {k v} + unset -nocomplain $vn +} -body { + array set $vn {a 1 b 2 c 3} + array for $vn $vn {} +} -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} catch {unset v} +catch {rename getbytes ""} catch {rename p ""} catch {namespace delete test_ns_var} catch {namespace delete test_ns_var2} diff --git a/tests/winDde.test b/tests/winDde.test index f04fb45..1fa7e86 100644 --- a/tests/winDde.test +++ b/tests/winDde.test @@ -20,7 +20,7 @@ testConstraint dde 0 if {[testConstraint win]} { if {![catch { ::tcltest::loadTestedCommands - set ::ddever [package require dde 1.4.0] + set ::ddever [package require dde 1.4.1] set ::ddelib [lindex [package ifneeded dde $::ddever] 1]}]} { testConstraint dde 1 } @@ -104,7 +104,7 @@ proc createChildProcess {ddeServerName args} { # ------------------------------------------------------------------------- test winDde-1.0 {check if we are testing the right dll} {win dde} { set ::ddever -} {1.4.0} +} {1.4.1} test winDde-1.1 {Settings the server's topic name} -constraints dde -body { list [dde servername foobar] [dde servername] [dde servername self] diff --git a/tests/winFCmd.test b/tests/winFCmd.test index a808c82..a0b7053 100644 --- a/tests/winFCmd.test +++ b/tests/winFCmd.test @@ -21,8 +21,7 @@ catch [list package require -exact Tcltest [info patchlevel]] # Initialise the test constraints testConstraint winVista 0 -testConstraint win2000orXP 0 -testConstraint winOlderThan2000 0 +testConstraint winXP 0 testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint testfile [llength [info commands testfile]] testConstraint testchmod [llength [info commands testchmod]] @@ -56,16 +55,11 @@ proc cleanup {args} { } } -if {[testConstraint winOnly]} { - set major [string index $tcl_platform(osVersion) 0] - if {[testConstraint nt] && $major > 4} { - if {$major > 5} { - testConstraint winVista 1 - } elseif {$major == 5} { - testConstraint win2000orXP 1 - } +if {[testConstraint win]} { + if {$::tcl_platform(osVersion) >= 5.0} { + testConstraint winVista 1 } else { - testConstraint winOlderThan2000 1 + testConstraint winXP 1 } } @@ -205,17 +199,12 @@ test winFCmd-1.12 {TclpRenameFile: errno: EACCES} -setup { } -returnCodes error -result EACCES test winFCmd-1.13 {TclpRenameFile: errno: EACCES} -setup { cleanup -} -constraints {win win2000orXP testfile} -body { +} -constraints {win winXP testfile} -body { testfile mv nul tf1 } -returnCodes error -result EINVAL -test winFCmd-1.14 {TclpRenameFile: errno: EACCES} -setup { - cleanup -} -constraints {win nt winOlderThan2000 testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result EACCES test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} -setup { cleanup -} -constraints {win nt testfile} -body { +} -constraints {win testfile} -body { createfile tf1 testfile mv tf1 nul } -returnCodes error -result EEXIST @@ -238,19 +227,12 @@ test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} -setup { } -returnCodes error -result ENOENT test winFCmd-1.19 {TclpRenameFile: errno == EACCES} -setup { cleanup -} -constraints {win win2000orXP testfile} -body { +} -constraints {win winXP testfile} -body { testfile mv nul tf1 } -returnCodes error -result EINVAL -test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} -setup { - cleanup -} -constraints {win nt winOlderThan2000 testfile} -body { - testfile mv nul tf1 -} -returnCodes error -result EACCES test winFCmd-1.20 {TclpRenameFile: src is dir} -setup { cleanup -} -constraints {win nt testfile} -body { - # under 95, this would actually succeed and move the current dir out from - # under the current process! +} -constraints {win testfile} -body { file delete /tf1 testfile mv [pwd] /tf1 } -returnCodes error -result EACCES @@ -458,14 +440,9 @@ test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} -setup { } -returnCodes error -result ENOENT test winFCmd-2.7 {TclpCopyFile: errno: EACCES} -setup { cleanup -} -constraints {win win2000orXP testfile} -body { +} -constraints {win winXP testfile} -body { testfile cp nul tf1 } -returnCodes error -result EINVAL -test winFCmd-2.8 {TclpCopyFile: errno: EACCES} -setup { - cleanup -} -constraints {win nt winOlderThan2000 testfile} -body { - testfile cp nul tf1 -} -returnCodes error -result EACCES test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} -setup { cleanup } -constraints {win testfile} -body { @@ -623,7 +600,7 @@ test winFCmd-3.11 {TclpDeleteFile: still can't remove path} -setup { test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} -body { testfile mkdir $cdrom/dummy~~.dir -} -constraints {win nt cdrom testfile} -returnCodes error -result EACCES +} -constraints {win cdrom testfile} -returnCodes error -result EACCES test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} -setup { cleanup } -constraints {win testfile} -body { @@ -721,7 +698,7 @@ test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} -setup { } -result {td1 EACCES} test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} -setup { cleanup -} -constraints {win nt testfile} -body { +} -constraints {win testfile} -body { testfile rmdir / # WinXP returns EEXIST, WinNT seems to return EACCES. No policy # decision has been made as to which is correct. @@ -819,7 +796,7 @@ test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} -setup { } -result {tf1} test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} -body { testfile rmdir $cdrom/ -} -constraints {win nt cdrom testfile} -returnCodes error -match glob \ +} -constraints {win cdrom testfile} -returnCodes error -match glob \ -result {* EACCES} test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} \ {win emptyTest} { @@ -857,7 +834,7 @@ test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} -setup { } -result {tf1} test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} -setup { cleanup -} -constraints {win nt testfile} -body { +} -constraints {win testfile} -body { file mkdir td1 testfile cpdir td1 / } -cleanup { @@ -1072,12 +1049,21 @@ test winFCmd-12.5 {ConvertFileNameFormat: absolute path} -body { } -constraints {win} -result {/ /} test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} -setup { catch {file delete -force -- c:/td1} -} -constraints {win win2000orXP} -body { +} -constraints {win winXP} -body { createfile c:/td1 {} string tolower [file attributes c:/td1 -longname] } -cleanup { file delete -force -- c:/td1 } -result {c:/td1} +test winFCmd-12.6.2 {ConvertFileNameFormat: absolute path with drive (in temp folder)} -setup { + catch {file delete -force -- $::env(TEMP)/td1} +} -constraints {win} -body { + createfile $::env(TEMP)/td1 {} + string equal [string tolower [file attributes $::env(TEMP)/td1 -longname]] \ + [string tolower [file normalize $::env(TEMP)]/td1] +} -cleanup { + file delete -force -- $::env(TEMP)/td1 +} -result 1 test winFCmd-12.7 {ConvertFileNameFormat} -body { string tolower [file attributes //bisque/tcl/ws -longname] } -constraints {nonPortable win} -result {//bisque/tcl/ws} @@ -1350,13 +1336,13 @@ test winFCmd-18.8 {Windows reserved path names} -constraints win -body { file normalize cOm1: } -result COM1 -test winFCmd-19.1 {Windows extended path names} -constraints nt -body { +test winFCmd-19.1 {Windows extended path names} -constraints win -body { file normalize //?/c:/windows/win.ini } -result //?/c:/windows/win.ini -test winFCmd-19.2 {Windows extended path names} -constraints nt -body { +test winFCmd-19.2 {Windows extended path names} -constraints win -body { file normalize //?/c:/windows/../windows/win.ini } -result //?/c:/windows/win.ini -test winFCmd-19.3 {Windows extended path names} -constraints nt -setup { +test winFCmd-19.3 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 20].tmp] set tmpfile [file normalize $tmpfile] } -body { @@ -1367,7 +1353,7 @@ test winFCmd-19.3 {Windows extended path names} -constraints nt -setup { } -cleanup { catch {file delete $tmpfile} } -result [list 0 {}] -test winFCmd-19.4 {Windows extended path names} -constraints nt -setup { +test winFCmd-19.4 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 20].tmp] set tmpfile //?/[file normalize $tmpfile] } -body { @@ -1378,7 +1364,7 @@ test winFCmd-19.4 {Windows extended path names} -constraints nt -setup { } -cleanup { catch {file delete $tmpfile} } -result [list 0 {}] -test winFCmd-19.5 {Windows extended path names} -constraints nt -setup { +test winFCmd-19.5 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp] set tmpfile [file normalize $tmpfile] } -body { @@ -1389,7 +1375,7 @@ test winFCmd-19.5 {Windows extended path names} -constraints nt -setup { } -cleanup { catch {file delete $tmpfile} } -result [list 0 {}] -test winFCmd-19.6 {Windows extended path names} -constraints nt -setup { +test winFCmd-19.6 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) tcl[string repeat x 248].tmp] set tmpfile //?/[file normalize $tmpfile] } -body { @@ -1400,7 +1386,7 @@ test winFCmd-19.6 {Windows extended path names} -constraints nt -setup { } -cleanup { catch {file delete $tmpfile} } -result [list 0 {}] -test winFCmd-19.7 {Windows extended path names} -constraints nt -setup { +test winFCmd-19.7 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) "tcl[pid].tmp "] set tmpfile [file normalize $tmpfile] } -body { @@ -1411,7 +1397,7 @@ test winFCmd-19.7 {Windows extended path names} -constraints nt -setup { } -cleanup { catch {file delete $tmpfile} } -result [list 0 {} [list tcl[pid].tmp]] -test winFCmd-19.8 {Windows extended path names} -constraints nt -setup { +test winFCmd-19.8 {Windows extended path names} -constraints win -setup { set tmpfile [file join $::env(TEMP) "tcl[pid].tmp "] set tmpfile //?/[file normalize $tmpfile] } -body { @@ -1423,7 +1409,7 @@ test winFCmd-19.8 {Windows extended path names} -constraints nt -setup { catch {file delete $tmpfile} } -result [list 0 {} [list "tcl[pid].tmp "]] -test winFCmd-19.9 {Windows devices path names} -constraints nt -body { +test winFCmd-19.9 {Windows devices path names} -constraints win -body { file normalize //./com1 } -result //./com1 diff --git a/tests/winFile.test b/tests/winFile.test index 2c47f5f..b2cdfa1 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -21,23 +21,19 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testvolumetype [llength [info commands testvolumetype]] testConstraint notNTFS 0 -testConstraint win2000 0 if {[testConstraint testvolumetype]} { testConstraint notNTFS [expr {[testvolumetype] eq "NTFS"}] } -if {[testConstraint nt] && $::tcl_platform(osVersion) >= 5.0} { - testConstraint win2000 1 -} test winFile-1.1 {TclpGetUserHome} -constraints {win} -body { glob ~nosuchuser } -returnCodes error -result {user "nosuchuser" doesn't exist} -test winFile-1.2 {TclpGetUserHome} -constraints {win nt nonPortable} -body { +test winFile-1.2 {TclpGetUserHome} -constraints {win nonPortable} -body { # The administrator account should always exist. glob ~administrator } -match glob -result * -test winFile-1.4 {TclpGetUserHome} {win nt nonPortable} { +test winFile-1.4 {TclpGetUserHome} {win nonPortable} { catch {glob ~stanton@workgroup} } {0} @@ -154,7 +150,7 @@ if {[testConstraint win]} { test winFile-4.0 { Enhanced NTFS user/group permissions: test no acccess } -constraints { - win nt notNTFS win2000 + win notNTFS } -setup { set owner [getuser $fname] set user $::env(USERDOMAIN)\\$::env(USERNAME) @@ -169,7 +165,7 @@ test winFile-4.0 { test winFile-4.1 { Enhanced NTFS user/group permissions: test readable only } -constraints { - win nt notNTFS + win notNTFS } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { @@ -180,7 +176,7 @@ test winFile-4.1 { test winFile-4.2 { Enhanced NTFS user/group permissions: test writable only } -constraints { - win nt notNTFS + win notNTFS } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { @@ -192,7 +188,7 @@ test winFile-4.2 { test winFile-4.3 { Enhanced NTFS user/group permissions: test read+write } -constraints { - win nt notNTFS + win notNTFS } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { @@ -205,7 +201,7 @@ test winFile-4.3 { test winFile-4.4 { Enhanced NTFS user/group permissions: test full access } -constraints { - win nt notNTFS + win notNTFS } -setup { set user $::env(USERDOMAIN)\\$::env(USERNAME) } -body { diff --git a/tests/winPipe.test b/tests/winPipe.test index 9c6f94d..361858a 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -30,18 +30,19 @@ 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 append big $big -append big $big +append big $big append big $big append big $big append big $big append big $big set path(little) [makeFile {} little] -set f [open $path(little) w] +set f [open $path(little) w] puts -nonewline $f "little" close $f @@ -74,11 +75,11 @@ test winpipe-1.2 {32 bit comprehensive tests: from big file} {win exec cat32} { exec $cat32 < $path(big) > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] } "{$big} stderr32" -test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {win nt exec cat32} { +test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {win exec cat32} { exec [interpreter] $path(more) < $path(little) | $cat32 > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] } {little stderr32} -test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win nt exec cat32} { +test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {win exec cat32} { exec [interpreter] $path(more) < $path(big) | $cat32 > $path(stdout) 2> $path(stderr) list [contents $path(stdout)] [contents $path(stderr)] } "{$big} stderr32" @@ -171,7 +172,7 @@ test winpipe-1.21 {32 bit comprehensive tests: read/write application} \ set r } "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" -test winpipe-4.1 {Tcl_WaitPid} {win nt exec cat32} { +test winpipe-4.1 {Tcl_WaitPid} {win exec cat32} { proc readResults {f} { global x result if { [eof $f] } { @@ -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: |