diff options
Diffstat (limited to 'tests')
102 files changed, 3425 insertions, 1420 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 0a6f57f..69a16ba 100644 --- a/tests/all.tcl +++ b/tests/all.tcl @@ -11,7 +11,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. package prefer latest -package require Tcl 8.5 +package require Tcl 8.5- package require tcltest 2.2 namespace import tcltest::* configure {*}$argv -testdir [file dir [info script]] 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 b0487e6..d17bfd9 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -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} { @@ -1201,7 +1201,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 +1310,7 @@ test assemble-11.10 {variable} { } # assemble-12 - ASSEM_LVT1 (incr and incrArray) - + test assemble-12.1 {incr - wrong # args} { -body { assemble {incr} @@ -1743,16 +1743,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 +1761,7 @@ test assemble-17.9 {jump - resolve a label multiple times} { append result pop jump common - + label common load case dup @@ -1780,7 +1780,7 @@ test assemble-17.9 {jump - resolve a label multiple times} { push 3 eq jumpTrue three - + label two pop incrImm case 1 @@ -1789,7 +1789,7 @@ test assemble-17.9 {jump - resolve a label multiple times} { append result pop jump common - + label three pop incrImm case 1 @@ -1887,7 +1887,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 +2080,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 +3066,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 +3170,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 +3180,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 +3232,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 +3242,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 @@ -3279,6 +3279,92 @@ test assemble-51.4 {memory leak testing} memory { } } } 0 + +test assemble-52.1 {Bug 3154ea2759} { + apply {{} { + # Needs six exception ranges to force the range allocations to use the + # malloced store. + ::tcl::unsupported::assemble { + beginCatch @badLabel + push error + push testing + invokeStk 2 + pop + push 0 + jump @okLabel + label @badLabel + push 1; # should be pushReturnCode + label @okLabel + endCatch + pop + + beginCatch @badLabel2 + push error + push testing + invokeStk 2 + pop + push 0 + jump @okLabel2 + label @badLabel2 + push 1; # should be pushReturnCode + label @okLabel2 + endCatch + pop + + beginCatch @badLabel3 + push error + push testing + invokeStk 2 + pop + push 0 + jump @okLabel3 + label @badLabel3 + push 1; # should be pushReturnCode + label @okLabel3 + endCatch + pop + + beginCatch @badLabel4 + push error + push testing + invokeStk 2 + pop + push 0 + jump @okLabel4 + label @badLabel4 + push 1; # should be pushReturnCode + label @okLabel4 + endCatch + pop + + beginCatch @badLabel5 + push error + push testing + invokeStk 2 + pop + push 0 + jump @okLabel5 + label @badLabel5 + push 1; # should be pushReturnCode + label @okLabel5 + endCatch + pop + + beginCatch @badLabel6 + push error + push testing + invokeStk 2 + pop + push 0 + jump @okLabel6 + label @badLabel6 + push 1; # should be pushReturnCode + label @okLabel6 + endCatch + pop + } + }} +} {}; # must not crash rename fillTables {} rename assemble {} 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/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 1a0037c..bff9a95 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -241,7 +241,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_*]} @@ -454,11 +454,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 @@ -476,11 +476,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 @@ -592,7 +592,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 { @@ -609,7 +609,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 { @@ -737,7 +737,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} @@ -810,7 +810,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 @@ -870,7 +870,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 @@ -881,7 +881,7 @@ test basic-48.16.$noComp {expansion: testing for leaks} -setup { test basic-48.17.$noComp {expansion: object safety} -setup { set old_precision $::tcl_precision set ::tcl_precision 4 - } -constraints $constraints -body { + } -constraints $constraints -body { set third [expr {1.0/3.0}] set l [list $third $third] set x [run {list $third {*}$l $third}] diff --git a/tests/binary.test b/tests/binary.test index 40b1315..7738f69 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2837,6 +2837,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 2738fc6..8e27af9 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -37,7 +37,7 @@ namespace eval ::tcl::test::io { ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] - + testConstraint testchannel [llength [info commands testchannel]] testConstraint exec [llength [info commands exec]] testConstraint openpipe 1 @@ -130,10 +130,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 +248,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 +259,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 +288,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 +353,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 +441,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 +750,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 +860,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 +871,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 +957,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 +1183,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 +1423,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 +1435,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 +1447,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 +1515,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 +3901,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 } @@ -4160,12 +4160,20 @@ test chan-io-33.4 {Tcl_Gets with long line} -setup { } -cleanup { chan close $f } -result {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} -test chan-io-33.5 {Tcl_Gets with long line} { +test chan-io-33.5 {Tcl_Gets with long line} -setup { + set f [open $path(test3) w] + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" + close $f +} -body { set f [open $path(test3)] set x [chan gets $f y] chan close $f list $x $y -} {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} +} -result {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} test chan-io-33.6 {Tcl_Gets and end of file} -setup { file delete $path(test3) set x {} @@ -5155,7 +5163,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] @@ -5300,7 +5308,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] \ @@ -5453,7 +5461,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 @@ -6765,7 +6773,12 @@ test chan-io-52.10 {TclCopyChannel & encodings} {fcopy} { chan close $out file size $path(utf8-fcopy.txt) } 5 -test chan-io-52.11 {TclCopyChannel & encodings} {fcopy} { +test chan-io-52.11 {TclCopyChannel & encodings} -setup { + set f [open $path(utf8-fcopy.txt) w] + fconfigure $f -encoding utf-8 -translation lf + puts $f "\u0410\u0410" + close $f +} -constraints {fcopy} -body { # binary to encoding => the input has to be in utf-8 to make sense to the # encoder set in [open $path(utf8-fcopy.txt) r] @@ -6777,7 +6790,9 @@ test chan-io-52.11 {TclCopyChannel & encodings} {fcopy} { chan close $in chan close $out file size $path(kyrillic.txt) -} 3 +} -cleanup { + file delete $path(utf8-fcopy.txt) +} -result 3 test chan-io-53.1 {CopyData} -setup { file delete $path(test1) diff --git a/tests/clock.test b/tests/clock.test index 2abeab9..6a0fecd 100644 --- a/tests/clock.test +++ b/tests/clock.test @@ -35,9 +35,9 @@ testConstraint y2038 \ # TEST PLAN # clock-1: -# [clock format] - tests of bad and empty arguments +# [clock format] - tests of bad and empty arguments # -# clock-2 +# clock-2 # formatting of year, month and day of month # # clock-3 @@ -195,7 +195,7 @@ namespace eval ::tcl::clock { l li lii liii liv lv lvi lvii lviii lix lx lxi lxii lxiii lxiv lxv lxvi lxvii lxviii lxix lxx lxxi lxxii lxxiii lxxiv lxxv lxxvi lxxvii lxxviii lxxix - lxxx lxxxi lxxxii lxxxiii lxxxiv lxxxv lxxxvi lxxxvii lxxxviii + lxxx lxxxi lxxxii lxxxiii lxxxiv lxxxv lxxxvi lxxxvii lxxxviii lxxxix xc xci xcii xciii xciv xcv xcvi xcvii xcviii xcix c @@ -271,7 +271,7 @@ test clock-1.3 "clock format - empty val" { test clock-1.4 "clock format - bad flag" {*}{ -body { list [catch {clock format 0 -oops badflag} msg] $msg $::errorCode - } + } -match glob -result {1 {bad option "-oops": must be -format, -gmt, -locale, or -timezone} {CLOCK badOption -oops}} } @@ -34992,6 +34992,10 @@ test clock-29.1800 {time parsing} { } 86399 # END testcases29 + +# BEGIN testcases30 + +# Test [clock add] test clock-30.1 {clock add years} { set t [clock scan 2000-01-01 -format %Y-%m-%d -timezone :UTC] set f [clock add $t 1 year -timezone :UTC] @@ -35218,10 +35222,61 @@ test clock-30.25 {clock add seconds at DST conversion} { set x1 [clock format $f1 -format {%Y-%m-%d %H:%M:%S %z} \ -timezone EST05:00EDT04:00,M4.1.0/02:00,M10.5.0/02:00] } {2004-10-31 01:00:00 -0500} +test clock-30.26 {clock add weekdays} { + set t [clock scan {2013-11-20}] ;# Wednesday + set f1 [clock add $t 3 weekdays] + set x1 [clock format $f1 -format {%Y-%m-%d}] +} {2013-11-25} +test clock-30.27 {clock add weekdays starting on Saturday} { + set t [clock scan {2013-11-23}] ;# Saturday + set f1 [clock add $t 1 weekday] + set x1 [clock format $f1 -format {%Y-%m-%d}] +} {2013-11-25} +test clock-30.28 {clock add weekdays starting on Sunday} { + set t [clock scan {2013-11-24}] ;# Sunday + set f1 [clock add $t 1 weekday] + set x1 [clock format $f1 -format {%Y-%m-%d}] +} {2013-11-25} +test clock-30.29 {clock add 0 weekdays starting on a weekend} { + set t [clock scan {2016-02-27}] ;# Saturday + set f1 [clock add $t 0 weekdays] + set x1 [clock format $f1 -format {%Y-%m-%d}] +} {2016-02-27} +test clock-30.30 {clock add weekdays and back} -body { + set n [clock seconds] + # we start on each day of the week + for {set i 0} {$i < 7} {incr i} { + set start [clock add $n $i days] + set startu [clock format $start -format %u] + # add 0 - 100 weekdays + for {set j 0} {$j < 100} {incr j} { + set forth [clock add $start $j weekdays] + set back [clock add $forth -$j weekdays] + # If $s was a weekday or $j was 0, $b must be the same day. + # Otherwise, $b must be the immediately preceeding Friday + set fail 0 + if {$j == 0 || $startu < 6} { + if {$start != $back} { set fail 1} + } else { + set friday [clock add $start -[expr {$startu % 5}] days] + if {$friday != $back} { set fail 1 } + } + if {$fail} { + set sdate [clock format $start -format {%Y-%m-%d}] + set bdate [clock format $back -format {%Y-%m-%d}] + return "$sdate + $j - $j := $bdate" + } + } + } + return "OK" +} -result {OK} + +# END testcases30 + test clock-31.1 {system locale} \ -constraints win \ - -setup { + -setup { namespace eval ::tcl::clock { namespace import -force ::testClock::registry } @@ -35244,7 +35299,7 @@ test clock-31.1 {system locale} \ test clock-31.2 {system locale} \ -constraints win \ - -setup { + -setup { namespace eval ::tcl::clock { namespace import -force ::testClock::registry } @@ -35267,7 +35322,7 @@ test clock-31.2 {system locale} \ test clock-31.3 {system locale} \ -constraints win \ - -setup { + -setup { namespace eval ::tcl::clock { namespace import -force ::testClock::registry } @@ -35290,7 +35345,7 @@ test clock-31.3 {system locale} \ test clock-31.4 {system locale} \ -constraints win \ - -setup { + -setup { namespace eval ::tcl::clock { namespace import -force ::testClock::registry } @@ -35327,7 +35382,7 @@ test clock-31.4 {system locale} \ test clock-31.5 {system locale} \ -constraints win \ - -setup { + -setup { namespace eval ::tcl::clock { namespace import -force ::testClock::registry } @@ -35364,7 +35419,7 @@ test clock-31.5 {system locale} \ test clock-31.6 {system locale} \ -constraints win \ - -setup { + -setup { namespace eval ::tcl::clock { namespace import -force ::testClock::registry } @@ -35434,7 +35489,7 @@ test clock-32.1 {scan/format across the Gregorian change} { } set problems } {} - + # Legacy tests # clock clicks @@ -35468,7 +35523,7 @@ test clock-33.5 {clock clicks tests, millisecond timing test} { # 60 msecs seems to be the max time slice under Windows 95/98 expr { ($end > $start) && (($end - $start) <= 60) ? - "ok" : + "ok" : "test should have taken 0-60 ms, actually took [expr $end - $start]"} } {ok} test clock-33.5a {clock tests, millisecond timing test} { @@ -35480,7 +35535,7 @@ test clock-33.5a {clock tests, millisecond timing test} { # 60 msecs seems to be the max time slice under Windows 95/98 expr { ($end > $start) && (($end - $start) <= 60) ? - "ok" : + "ok" : "test should have taken 0-60 ms, actually took [expr $end - $start]"} } {ok} test clock-33.6 {clock clicks, milli with too much abbreviation} { @@ -35804,31 +35859,31 @@ test clock-34.47 {ago with multiple relative units} { } 180000 test clock-34.48 {more than one ToD} {*}{ - -body {clock scan {10:00 11:00}} + -body {clock scan {10:00 11:00}} -returnCodes error -result {unable to convert date-time string "10:00 11:00": more than one time of day in string} } test clock-34.49 {more than one date} {*}{ - -body {clock scan {1/1/2001 2/2/2002}} + -body {clock scan {1/1/2001 2/2/2002}} -returnCodes error -result {unable to convert date-time string "1/1/2001 2/2/2002": more than one date in string} } test clock-34.50 {more than one time zone} {*}{ - -body {clock scan {10:00 EST CST}} + -body {clock scan {10:00 EST CST}} -returnCodes error -result {unable to convert date-time string "10:00 EST CST": more than one time zone in string} } test clock-34.51 {more than one weekday} {*}{ - -body {clock scan {Monday Tuesday}} + -body {clock scan {Monday Tuesday}} -returnCodes error -result {unable to convert date-time string "Monday Tuesday": more than one weekday in string} } test clock-34.52 {more than one ordinal month} {*}{ - -body {clock scan {next January next March}} + -body {clock scan {next January next March}} -returnCodes error -result {unable to convert date-time string "next January next March": more than one ordinal month in string} } @@ -35924,7 +35979,7 @@ test clock-38.2 {make sure TZ is not cached after unset} \ } } \ -result 1 - + test clock-39.1 {regression - synonym timezones} { clock format 0 -format {%H:%M:%S} -timezone :US/Eastern @@ -35996,7 +36051,7 @@ test clock-44.1 {regression test - time zone name containing hyphen } \ } } \ -result {12:34:56-0500} - + test clock-45.1 {regression test - time zone containing only two digits} \ -body { clock scan 1985-04-12T10:15:30+04 -format %Y-%m-%dT%H:%M:%S%Z @@ -36041,7 +36096,7 @@ test clock-48.1 {Bug 1185933: 'i' destroyed by clock init} -setup { test clock-49.1 {regression test - localtime with negative arg (Bug 1237907)} \ -body { - list [catch { + list [catch { clock format -86400 -timezone :localtime -format %Y } result] $result } \ @@ -36280,7 +36335,7 @@ test clock-56.1 {use of zoneinfo, version 1} {*}{ } -result {2004-01-01 00:00:00 MST} } - + test clock-56.2 {use of zoneinfo, version 2} {*}{ -setup { clock format [clock seconds] @@ -36330,7 +36385,7 @@ test clock-56.2 {use of zoneinfo, version 2} {*}{ removeFile PhoenixTwo $tzdir2 removeDirectory Test $tzdir removeDirectory zoneinfo - } + } -body { clock format 1072940400 -timezone :Test/PhoenixTwo \ -format {%Y-%m-%d %H:%M:%S %Z} @@ -36540,7 +36595,7 @@ test clock-56.3 {use of zoneinfo, version 2, Y2038 compliance} {*}{ removeFile TijuanaTwo $tzdir2 removeDirectory Test $tzdir removeDirectory zoneinfo - } + } -body { clock format 2224738800 -timezone :Test/TijuanaTwo \ -format {%Y-%m-%d %H:%M:%S %Z} @@ -36692,7 +36747,7 @@ test clock-56.4 {Bug 3470928} {*}{ removeFile Windhoek $tzdir2 removeDirectory Test $tzdir removeDirectory zoneinfo - } + } -result {Sun Jan 08 22:30:06 WAST 2012} } @@ -36703,7 +36758,7 @@ test clock-57.1 {clock scan - abbreviated options} { test clock-58.1 {clock l10n - Japanese localisation} {*}{ -setup { proc backslashify { string } { - + set retval {} foreach char [split $string {}] { scan $char %c ccode @@ -36809,52 +36864,52 @@ test clock-59.1 {military time zones} { test clock-60.1 {case insensitive weekday names} { clock scan "2000-W01 monday" -gmt true -format "%G-W%V %a" -} [clock scan "2000-W01-1" -gmt true -format "%G-W%V-%u"] +} [clock scan "2000-W01-1" -gmt true -format "%G-W%V-%u"] test clock-60.2 {case insensitive weekday names} { clock scan "2000-W01 Monday" -gmt true -format "%G-W%V %a" -} [clock scan "2000-W01-1" -gmt true -format "%G-W%V-%u"] +} [clock scan "2000-W01-1" -gmt true -format "%G-W%V-%u"] test clock-60.3 {case insensitive weekday names} { clock scan "2000-W01 MONDAY" -gmt true -format "%G-W%V %a" -} [clock scan "2000-W01-1" -gmt true -format "%G-W%V-%u"] +} [clock scan "2000-W01-1" -gmt true -format "%G-W%V-%u"] test clock-60.4 {case insensitive weekday names} { clock scan "2000-W01 friday" -gmt true -format "%G-W%V %a" -} [clock scan "2000-W01-5" -gmt true -format "%G-W%V-%u"] +} [clock scan "2000-W01-5" -gmt true -format "%G-W%V-%u"] test clock-60.5 {case insensitive weekday names} { clock scan "2000-W01 Friday" -gmt true -format "%G-W%V %a" -} [clock scan "2000-W01-5" -gmt true -format "%G-W%V-%u"] +} [clock scan "2000-W01-5" -gmt true -format "%G-W%V-%u"] test clock-60.6 {case insensitive weekday names} { clock scan "2000-W01 FRIDAY" -gmt true -format "%G-W%V %a" -} [clock scan "2000-W01-5" -gmt true -format "%G-W%V-%u"] +} [clock scan "2000-W01-5" -gmt true -format "%G-W%V-%u"] test clock-60.7 {case insensitive month names} { clock scan "1 january 2000" -gmt true -format "%d %b %Y" -} [clock scan "2000-01-01" -gmt true -format "%Y-%m-%d"] +} [clock scan "2000-01-01" -gmt true -format "%Y-%m-%d"] test clock-60.8 {case insensitive month names} { clock scan "1 January 2000" -gmt true -format "%d %b %Y" -} [clock scan "2000-01-01" -gmt true -format "%Y-%m-%d"] +} [clock scan "2000-01-01" -gmt true -format "%Y-%m-%d"] test clock-60.9 {case insensitive month names} { clock scan "1 JANUARY 2000" -gmt true -format "%d %b %Y" -} [clock scan "2000-01-01" -gmt true -format "%Y-%m-%d"] +} [clock scan "2000-01-01" -gmt true -format "%Y-%m-%d"] test clock-60.10 {case insensitive month names} { clock scan "1 december 2000" -gmt true -format "%d %b %Y" -} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"] +} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"] test clock-60.11 {case insensitive month names} { clock scan "1 December 2000" -gmt true -format "%d %b %Y" -} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"] +} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"] test clock-60.12 {case insensitive month names} { clock scan "1 DECEMBER 2000" -gmt true -format "%d %b %Y" -} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"] +} [clock scan "2000-12-01" -gmt true -format "%Y-%m-%d"] test clock-61.1 {overflow of a wide integer on output} {*}{ -body { clock format 0x8000000000000000 -format %s -gmt true - } + } -result {integer value too large to represent} -returnCodes error } test clock-61.2 {overflow of a wide integer on output} {*}{ -body { clock format -0x8000000000000001 -format %s -gmt true - } + } -result {integer value too large to represent} -returnCodes error } @@ -36931,11 +36986,37 @@ test clock-67.2 {Bug d19a30db57} -body { # error, not segfault tcl::clock::GetJulianDayFromEraYearMonthDay {} 2361222 } -returnCodes error -match glob -result * + test clock-67.3 {Bug d19a30db57} -body { # error, not segfault tcl::clock::GetJulianDayFromEraYearWeekDay {} 2361222 } -returnCodes error -match glob -result * +test clock-67.4 {Change format %x output on global locale change [Bug 4a0c163d24]} -setup { + package require msgcat + set current [msgcat::mclocale] +} -body { + msgcat::mclocale de_de + set res [regexp {^\d{2}\.\d{2}\.\d{4}$} [clock format 1 -locale current -format %x]] + msgcat::mclocale en_uk + lappend res [regexp {^\d{2}/\d{2}/\d{4}$} [clock format 1 -locale current -format %x]] +} -cleanup { + msgcat::mclocale $current +} -result {1 1} + +test clock-67.5 {Change scan %x output on global locale change [Bug 4a0c163d24]} -setup { + package require msgcat + set current [msgcat::mclocale] +} -body { + msgcat::mclocale de_de + set res [clock scan "01.01.1970" -locale current -format %x -gmt 1] + msgcat::mclocale en_uk + # This will fail without the bug fix, as still de_de is active + expr {$res == [clock scan "01/01/1970" -locale current -format %x -gmt 1]} +} -cleanup { + msgcat::mclocale $current +} -result {1} + # cleanup namespace delete ::testClock diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 64cfeba..3c58c1b 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -141,9 +141,13 @@ test cmdAH-2.6.2 {cd} -constraints {unix nonPortable} -setup { } -cleanup { cd $dir } -result {/} -test cmdAH-2.6.3 {Tcl_CdObjCmd, bug #3118489} -returnCodes error -body { +test cmdAH-2.6.3 {Tcl_CdObjCmd, bug #3118489} -setup { + set dir [pwd] +} -returnCodes error -body { cd .\0 -} -result "couldn't change working directory to \".\0\": no such file or directory" +} -cleanup { + cd $dir +} -match glob -result "couldn't change working directory to \".\0\": *" test cmdAH-2.7 {Tcl_ConcatObjCmd} { concat } {} @@ -163,10 +167,10 @@ test cmdAH-3.2 {Tcl_ContinueObjCmd, success} { test cmdAH-4.1 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding -} -result {wrong # args: should be "encoding option ?arg ...?"} +} -result {wrong # args: should be "encoding subcommand ?arg ...?"} test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding foo -} -result {bad option "foo": must be convertfrom, convertto, dirs, names, or system} +} -result {unknown or ambiguous subcommand "foo": must be convertfrom, convertto, dirs, names, or system} test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { encoding convertto } -result {wrong # args: should be "encoding convertto ?encoding? data"} @@ -878,20 +882,20 @@ test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unix testchmod} { } 1 test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body { # On pc, must be a .exe, .com, etc. - set x [file exe $gorpfile] - set gorpexe [makeFile foo gorp.exe] - lappend x [file exe $gorpexe] -} -cleanup { - removeFile $gorpexe -} -result {0 1} -test cmdAH-18.5.1 {Tcl_FileObjCmd: executable} -constraints {win} -body { - # On pc, must be a .exe, .com, etc. - set x [file exe $gorpfile] - set gorpexe [makeFile foo gorp.exe] - lappend x [file exe [string toupper $gorpexe]] + set x {} + set gorpexes {} + foreach ext {exe com cmd bat} { + lappend x [file exe nosuchfile.$ext] + set gorpexe [makeFile foo gorp.$ext] + lappend gorpexes $gorpexe + lappend x [file exe $gorpexe] [file exe [string toupper $gorpexe]] + } + set x } -cleanup { - removeFile $gorpexe -} -result {0 1} + foreach gorpexe $gorpexes { + removeFile $gorpexe + } +} -result {0 1 1 0 1 1 0 1 1 0 1 1} test cmdAH-18.6 {Tcl_FileObjCmd: executable} {} { # Directories are always executable. file exe $dirfile @@ -1027,6 +1031,16 @@ test cmdAH-20.6 {Tcl_FileObjCmd: atime touch} -setup { set modatime [file atime $file $newatime] expr {$newatime == $modatime ? 1 : "$newatime != $modatime"} } -result 1 +test cmdAH-20.7 { + Tcl_FileObjCmd: atime (built-in Windows names) +} -constraints {win} -body { + file atime con +} -result "could not get access time for file \"con\"" -returnCodes error +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 if {[testConstraint unix] && [file exists /tmp]} { removeFile touch.me /tmp @@ -1258,6 +1272,16 @@ test cmdAH-24.13 {Tcl_FileObjCmd: directory mtime} -setup { } -cleanup { file delete -force $dirname } -result {0 1} +test cmdAH-24.14 { + Tcl_FileObjCmd: mtime (built-in Windows names) +} -constraints {win} -body { + file mtime con +} -result "could not get modification time for file \"con\"" -returnCodes error +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 # owned test cmdAH-25.1 {Tcl_FileObjCmd: owned} -returnCodes error -body { @@ -1277,6 +1301,12 @@ test cmdAH-25.2.1 {Tcl_FileObjCmd: owned} -constraints unix -setup { test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unix notRoot} { file owned / } 0 +test cmdAH-25.3.1 {Tcl_FileObjCmd: owned} -constraints win -body { + file owned $env(windir) +} -result 0 +test cmdAH-25.4 {Tcl_FileObjCmd: owned} -body { + file owned nosuchfile +} -result 0 # readlink test cmdAH-26.1 {Tcl_FileObjCmd: readlink} -returnCodes error -body { @@ -1307,6 +1337,16 @@ test cmdAH-27.2 {Tcl_FileObjCmd: size} { test cmdAH-27.3 {Tcl_FileObjCmd: size} { list [catch {file size _bogus_} msg] [string tolower $msg] $errorCode } {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} +test cmdAH-27.4 { + Tcl_FileObjCmd: size (built-in Windows names) +} -constraints {win} -body { + file size con +} -result 0 +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] +} -result 0 catch {testsetplatform $platform} removeFile $gorpfile @@ -1398,12 +1438,24 @@ test cmdAH-28.12 {Tcl_FileObjCmd: stat} -setup { } -cleanup { removeFile $filename } -result 1 +test cmdAH-28.13 {Tcl_FileObjCmd: stat (built-in Windows names)} -constraints {win} -setup { + unset -nocomplain stat +} -body { + file stat con stat + lmap elem {atime ctime dev gid ino mode mtime nlink size type uid} {set stat($elem)} +} -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0} +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)} +} -result {0 0 -1 0 0 8630 0 0 0 characterSpecial 0} unset -nocomplain stat # type test cmdAH-29.1 {Tcl_FileObjCmd: type} -returnCodes error -body { - file size a b -} -result {wrong # args: should be "file size name"} + file type a b +} -result {wrong # args: should be "file type name"} test cmdAH-29.2 {Tcl_FileObjCmd: type} { file type $dirfile } directory @@ -1438,6 +1490,16 @@ test cmdAH-29.4.1 {Tcl_FileObjCmd: type} -constraints {linkDirectory} -setup { test cmdAH-29.5 {Tcl_FileObjCmd: type} { list [catch {file type _bogus_} msg] [string tolower $msg] $errorCode } {1 {could not read "_bogus_": no such file or directory} {POSIX ENOENT {no such file or directory}}} +test cmdAH-29.6 { + Tcl_FileObjCmd: type (built-in Windows names) +} -constraints {win} -body { + file type con +} -result "characterSpecial" +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] +} -result "characterSpecial" # Error conditions test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { 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/compile.test b/tests/compile.test index d4a31d4..2fa4147 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} @@ -224,6 +224,17 @@ test compile-5.2 {TclCompileForeachCmd: non-local variables} { foreach-test set ::foo } 3 +test compile-5.3 {TclCompileForeachCmd: [Bug b9b2079e6d]} -setup { + proc demo {} { + foreach x y { + if 1 break else + } + } +} -body { + demo +} -cleanup { + rename demo {} +} -returnCodes error -result {wrong # args: no script following "else" argument} test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} -setup { catch {unset x} @@ -333,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"] @@ -348,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] @@ -372,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 @@ -465,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 {$}] @@ -667,7 +678,7 @@ test compile-17.2 {Command interpretation binding for non-compiled code} -setup # change without warning. set disassemblables [linsert [join { - lambda method objmethod proc script + constructor destructor lambda method objmethod proc script } ", "] end-1 or] test compile-18.1 {disassembler - basics} -returnCodes error -body { tcl::unsupported::disassemble @@ -765,7 +776,7 @@ test compile-18.24 {disassembler - basics} -returnCodes error -body { } -result "can't interpret \"\{\" as a lambda expression" test compile-18.25 {disassembler - basics} -body { dict keys [tcl::unsupported::getbytecode lambda {{} {}}] -} -result $bytecodekeys +} -result "$bytecodekeys initiallinenumber sourcefile" test compile-18.26 {disassembler - basics} -returnCodes error -body { tcl::unsupported::getbytecode proc } -match glob -result {wrong # args: should be "* proc procName"} @@ -778,7 +789,43 @@ test compile-18.28 {disassembler - basics} -setup { dict keys [tcl::unsupported::getbytecode proc chewonthis] } -cleanup { rename chewonthis {} +} -result "$bytecodekeys initiallinenumber sourcefile" +test compile-18.28.1 {disassembler - tricky bit} -setup { + eval [list proc chewonthis {} {}] +} -body { + dict keys [tcl::unsupported::getbytecode proc chewonthis] +} -cleanup { + rename chewonthis {} +} -result $bytecodekeys +test compile-18.28.2 {disassembler - tricky bit} -setup { + eval {proc chewonthis {} {}} +} -body { + dict keys [tcl::unsupported::getbytecode proc chewonthis] +} -cleanup { + rename chewonthis {} +} -result "$bytecodekeys initiallinenumber sourcefile" +test compile-18.28.3 {disassembler - tricky bit} -setup { + proc Proc {n a b} { + proc $n $a $b + } + Proc chewonthis {} {} +} -body { + dict keys [tcl::unsupported::getbytecode proc chewonthis] +} -cleanup { + rename Proc {} + rename chewonthis {} } -result $bytecodekeys +test compile-18.28.4 {disassembler - tricky bit} -setup { + proc Proc {n a b} { + tailcall proc $n $a $b + } + Proc chewonthis {} {} +} -body { + dict keys [tcl::unsupported::getbytecode proc chewonthis] +} -cleanup { + rename Proc {} + rename chewonthis {} +} -result "$bytecodekeys initiallinenumber sourcefile" test compile-18.29 {disassembler - basics} -returnCodes error -body { tcl::unsupported::getbytecode script } -match glob -result {wrong # args: should be "* script script"} @@ -807,7 +854,7 @@ test compile-18.35 {disassembler - basics} -setup { dict keys [tcl::unsupported::getbytecode method foo bar] } -cleanup { foo destroy -} -result $bytecodekeys +} -result "$bytecodekeys initiallinenumber sourcefile" test compile-18.36 {disassembler - basics} -returnCodes error -body { tcl::unsupported::getbytecode objmethod } -match glob -result {wrong # args: should be "* objmethod objectName methodName"} @@ -824,7 +871,104 @@ test compile-18.39 {disassembler - basics} -setup { dict keys [tcl::unsupported::getbytecode objmethod foo bar] } -cleanup { foo destroy -} -result $bytecodekeys +} -result "$bytecodekeys initiallinenumber sourcefile" +test compile-18.40 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble constructor +} -match glob -result {wrong # args: should be "* constructor className"} +test compile-18.41 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble constructor nosuchclass +} -result {nosuchclass does not refer to an object} +test compile-18.42 {disassembler - basics} -returnCodes error -setup { + oo::object create justanobject +} -body { + tcl::unsupported::disassemble constructor justanobject +} -cleanup { + justanobject destroy +} -result {"justanobject" is not a class} +test compile-18.43 {disassembler - basics} -returnCodes error -setup { + oo::class create constructorless +} -body { + tcl::unsupported::disassemble constructor constructorless +} -cleanup { + constructorless destroy +} -result {"constructorless" has no defined constructor} +test compile-18.44 {disassembler - basics} -setup { + oo::class create foo {constructor {} {set x 1}} +} -body { + # Allow any string: the result format is not defined anywhere! + tcl::unsupported::disassemble constructor foo +} -cleanup { + foo destroy +} -match glob -result * +test compile-18.45 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode constructor +} -match glob -result {wrong # args: should be "* constructor className"} +test compile-18.46 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode constructor nosuchobject +} -result {nosuchobject does not refer to an object} +test compile-18.47 {disassembler - basics} -returnCodes error -setup { + oo::class create constructorless +} -body { + tcl::unsupported::getbytecode constructor constructorless +} -cleanup { + constructorless destroy +} -result {"constructorless" has no defined constructor} +test compile-18.48 {disassembler - basics} -setup { + oo::class create foo {constructor {} {set x 1}} +} -body { + dict keys [tcl::unsupported::getbytecode constructor foo] +} -cleanup { + foo destroy +} -result "$bytecodekeys" +# There is no compile-18.49 +test compile-18.50 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble destructor +} -match glob -result {wrong # args: should be "* destructor className"} +test compile-18.51 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::disassemble destructor nosuchclass +} -result {nosuchclass does not refer to an object} +test compile-18.52 {disassembler - basics} -returnCodes error -setup { + oo::object create justanobject +} -body { + tcl::unsupported::disassemble destructor justanobject +} -cleanup { + justanobject destroy +} -result {"justanobject" is not a class} +test compile-18.53 {disassembler - basics} -returnCodes error -setup { + oo::class create constructorless +} -body { + tcl::unsupported::disassemble destructor constructorless +} -cleanup { + constructorless destroy +} -result {"constructorless" has no defined destructor} +test compile-18.54 {disassembler - basics} -setup { + oo::class create foo {destructor {set x 1}} +} -body { + # Allow any string: the result format is not defined anywhere! + tcl::unsupported::disassemble destructor foo +} -cleanup { + foo destroy +} -match glob -result * +test compile-18.55 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode destructor +} -match glob -result {wrong # args: should be "* destructor className"} +test compile-18.56 {disassembler - basics} -returnCodes error -body { + tcl::unsupported::getbytecode destructor nosuchobject +} -result {nosuchobject does not refer to an object} +test compile-18.57 {disassembler - basics} -returnCodes error -setup { + oo::class create constructorless +} -body { + tcl::unsupported::getbytecode destructor constructorless +} -cleanup { + constructorless destroy +} -result {"constructorless" has no defined destructor} +test compile-18.58 {disassembler - basics} -setup { + oo::class create foo {destructor {set x 1}} +} -body { + dict keys [tcl::unsupported::getbytecode destructor foo] +} -cleanup { + foo destroy +} -result "$bytecodekeys" test compile-19.0 {Bug 3614102: reset stack housekeeping} -body { # This will panic in a --enable-symbols=compile build, unless bug is fixed. diff --git a/tests/coroutine.test b/tests/coroutine.test index 205da67..86fa6e3 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 {}} diff --git a/tests/dict.test b/tests/dict.test index d5406d0..a6b0cb4 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -2048,6 +2048,13 @@ test dict-24.25 {dict map with huge dict (compiled)} { }} 100000 } 166666666600000 +test dict-25.1 {compiled dict update with low-refcount values [Bug d553228d9f]} { + # Test crashes on failure + apply {{} { + lassign {} item + dict update item item item two two {} + }} +} {} # cleanup ::tcltest::cleanupTests diff --git a/tests/encoding.test b/tests/encoding.test index 0374e2d..4dddbb5 100644 --- a/tests/encoding.test +++ b/tests/encoding.test @@ -73,7 +73,7 @@ test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup { } -constraints {testencoding} -body { encoding system shiftjis ;# incr ref count encoding dirs [list [pwd]] - set x [encoding convertto shiftjis \u4e4e] ;# old one found + set x [encoding convertto shiftjis \u4e4e] ;# old one found encoding system identity llength shiftjis ;# Shimmer away any cache of Tcl_Encoding lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg @@ -182,7 +182,7 @@ test encoding-8.1 {Tcl_ExternalToUtf} { puts -nonewline $f "ab\x8c\xc1g" close $f set f [open [file join [temporaryDirectory] dummy] r] - fconfigure $f -translation binary -encoding shiftjis + fconfigure $f -translation binary -encoding shiftjis set x [read $f] close $f file delete [file join [temporaryDirectory] dummy] @@ -265,7 +265,7 @@ test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} makeDirectory tmp makeDirectory [file join tmp encoding] set f [open [file join tmp encoding splat.enc] w] - fconfigure $f -translation binary + fconfigure $f -translation binary puts $f "abcdefghijklmnop" close $f encoding convertto splat \u4e4e @@ -286,11 +286,11 @@ test encoding-12.1 {LoadTableEncoding: normal encoding} { append x [encoding convertfrom iso8859-3 \xd5] } "\xd5?\u120" test encoding-12.2 {LoadTableEncoding: single-byte encoding} { - set x [encoding convertto iso8859-3 ab\u0120g] + set x [encoding convertto iso8859-3 ab\u0120g] append x [encoding convertfrom iso8859-3 ab\xd5g] } "ab\xd5gab\u120g" test encoding-12.3 {LoadTableEncoding: multi-byte encoding} { - set x [encoding convertto shiftjis ab\u4e4eg] + set x [encoding convertto shiftjis ab\u4e4eg] append x [encoding convertfrom shiftjis ab\x8c\xc1g] } "ab\x8c\xc1gab\u4e4eg" test encoding-12.4 {LoadTableEncoding: double-byte encoding} { diff --git a/tests/env.test b/tests/env.test index 83d99e0..0dd4f98 100644 --- a/tests/env.test +++ b/tests/env.test @@ -19,7 +19,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { # Some tests require the "exec" command. # Skip them if exec is not defined. testConstraint exec [llength [info commands exec]] - + # # These tests will run on any platform (and indeed crashed on the Mac). So put # them before you test for the existance of exec. @@ -147,6 +147,7 @@ test env-2.2 {adding environment variables} -setup { } -result {NAME1=test string} test env-2.3 {adding environment variables} -setup { encoding system iso8859-1 + set env(NAME1) "test string" } -constraints {exec} -body { set env(NAME2) "more" getenv @@ -156,6 +157,8 @@ test env-2.3 {adding environment variables} -setup { NAME2=more} test env-2.4 {adding environment variables} -setup { encoding system iso8859-1 + set env(NAME1) "test string" + set env(NAME2) "more" } -constraints {exec} -body { set env(XYZZY) "garbage" getenv @@ -165,7 +168,9 @@ test env-2.4 {adding environment variables} -setup { 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 { @@ -177,6 +182,7 @@ test env-3.1 {changing environment variables} -setup { } -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 @@ -195,6 +201,7 @@ test env-4.2 {unsetting environment variables} -setup { 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 { @@ -213,6 +220,7 @@ test env-4.4 {changing international environment variables} -setup { } -result {\u00a7=\u00a7} test env-4.5 {unsetting international environment variables} -setup { encoding system iso8859-1 + set env(\ua7) \ua7 } -body { set env(\ub6) \ua7 unset env(\ua7) @@ -278,20 +286,20 @@ test env-5.4 {corner cases - unset the env array} -setup { } -cleanup { interp delete i } -result {1 a 1} -test env-5.5 {corner cases - cannot have null entries on Windows} {win} { +test env-5.5 {corner cases - cannot have null entries on Windows} -constraints win -body { set env() a catch {set env()} -} {1} +} -result 1 -test env-6.1 {corner cases - add lots of env variables} {} { +test env-6.1 {corner cases - add lots of env variables} -body { set size [array size env] for {set i 0} {$i < 100} {incr i} { set env(BOGUS$i) $i } expr {[array size env] - $size} -} 100 +} -result 100 -test env-7.1 {[219226]: whole env array should not be unset by read} { +test env-7.1 {[219226]: whole env array should not be unset by read} -body { set n [array size env] set s [array startsearch env] while {[array anymore env $s]} { @@ -300,20 +308,30 @@ test env-7.1 {[219226]: whole env array should not be unset by read} { } array donesearch env $s return $n -} 0 -test env-7.2 {[219226]: links to env elements should not be removed by read} { +} -result 0 + +test env-7.2 {[219226]: links to env elements should not be removed by read} -body { apply {{} { set ::env(test7_2) ok upvar env(test7_2) elem set ::env(PATH) - try { - return $elem - } finally { - unset ::env(test7_2) - } + return $elem }} -} ok +} -result ok +test env-7.3 {[9b4702]: testing existence of env(some_thing) should not destroy trace} -body { + apply {{} { + catch {unset ::env(test7_3)} + proc foo args { + set ::env(test7_3) ok + } + trace add variable ::env(not_yet_existent) write foo + info exists ::env(not_yet_existent) + set ::env(not_yet_existent) "Now I'm here"; + return [info exists ::env(test7_3)] + }} +} -result 1 + # Restore the environment variables at the end of the test. foreach name [array names env] { diff --git a/tests/event.test b/tests/event.test index 0d1b06c..ef0947f 100644 --- a/tests/event.test +++ b/tests/event.test @@ -583,6 +583,34 @@ test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} { removeFile $test2file list $x $y $z } {3 3 done} +test event-11.7 {Bug 16828b3744} { + after idle { + set ::t::v 1 + namespace delete ::t + } + namespace eval ::t { + vwait ::t::v + } +} {} +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 +} -cleanup { + A destroy +} -result {} test event-12.1 {Tcl_UpdateCmd procedure} -returnCodes error -body { update a b diff --git a/tests/exec.test b/tests/exec.test index 16a8320..2a4b31e 100644 --- a/tests/exec.test +++ b/tests/exec.test @@ -682,6 +682,19 @@ test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix} -setup { } -cleanup { removeFile $tmpfile } -result 14 + +# Tests to ensure batch files and .CMD (Bug 9ece99d58b) +# can be executed on Windows +test exec-20.0 {exec .bat file} -constraints {win} -body { + set log [makeFile {} exec20.log] + exec [makeFile "echo %1> $log" exec20.bat] "Testing exec-20.0" + viewFile $log +} -result "\"Testing exec-20.0\"" +test exec-20.1 {exec .CMD file} -constraints {win} -body { + set log [makeFile {} exec201.log] + 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 9a2ffbd..5b8ce2d 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -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 @@ -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..3adfb63 100644 --- a/tests/expr-old.test +++ b/tests/expr-old.test @@ -420,13 +420,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" @@ -1120,7 +1120,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 diff --git a/tests/expr.test b/tests/expr.test index 4c03262..8e083c5 100644 --- a/tests/expr.test +++ b/tests/expr.test @@ -910,6 +910,15 @@ test expr-22.9 {non-numeric floats: shared object equality and NaN} { set x NaN expr {$x == $x} } 0 +# Make sure [Bug d0f7ba56f0] stays fixed. +test expr-22.10 {non-numeric arguments: equality and NaN} { + set x NaN + expr {$x > "Gran"} +} 1 +test expr-22.11 {non-numeric arguments: equality and NaN} { + set x NaN + expr {"Gran" < $x} +} 1 # Tests for exponentiation handling test expr-23.1 {CompileExponentialExpr: just exponential expr} {expr 4**2} 16 @@ -1429,7 +1438,7 @@ 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 @@ -5777,7 +5786,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} \ @@ -6776,7 +6785,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} diff --git a/tests/fCmd.test b/tests/fCmd.test index c8264b2..709bfb4 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 @@ -66,12 +66,10 @@ 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 {$major > 5} { + testConstraint winVista 1 + } else { + testConstraint winXP 1 } } @@ -792,7 +790,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 +822,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 diff --git a/tests/fileName.test b/tests/fileName.test index 51f00d1..387d844 100644 --- a/tests/fileName.test +++ b/tests/fileName.test @@ -1468,14 +1468,16 @@ if {[testConstraint testsetplatform]} { } test filename-17.2 {windows specific glob with executable} -body { makeDirectory execglob - makeFile contents execglob/abc.exe - makeFile contents execglob/abc.notexecutable - glob -nocomplain -dir [temporaryDirectory]/execglob -tails -types x * + foreach ext {exe com cmd bat notexecutable} { + makeFile contents execglob/abc.$ext + } + lsort [glob -nocomplain -dir [temporaryDirectory]/execglob -tails -types x *] } -constraints {win} -cleanup { - removeFile execglob/abc.exe - removeFile execglob/abc.notexecutable + foreach ext {exe com cmd bat ps1 notexecutable} { + removeFile execglob/abc.$ext + } removeDirectory execglob -} -result {abc.exe} +} -result {abc.bat abc.cmd abc.com abc.exe} test filename-17.3 {Bug 2571597} win { set p /a file pathtype $p diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 9fe4fe9..1941936 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 @@ -874,7 +874,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/format.test b/tests/format.test index 27eac31..a4ea25e 100644 --- a/tests/format.test +++ b/tests/format.test @@ -21,6 +21,7 @@ testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}] testConstraint wideIs64bit \ [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] +testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}] test format-1.1 {integer formatting} { format "%*d %d %d %d" 6 34 16923 -12 -1 @@ -349,9 +350,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 @@ -363,6 +364,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} @@ -528,6 +549,12 @@ test format-17.3 {testing %ld with non-wide} {wideIs64bit} { test format-17.4 {testing %l with non-integer} { format %lf 1 } 1.000000 +test format-17.5 {testing %llu with bignum} { + format %llu 0xabcdef0123456789abcdef +} 207698809136909011942886895 +test format-17.6 {testing %llu with negative number} -body { + format %llu -1 +} -returnCodes 1 -result {unsigned bignum format is invalid} test format-18.1 {do not demote existing numeric values} { set a 0xaaaaaaaa @@ -564,9 +591,12 @@ test format-19.3 {Bug 2830354} { test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body { set x [dict create a b c d] format %s $x - # After this, obj in $x should be a dict with a non-NULL bytes field + # After this, obj in $x should be a dict + # We are testing to make sure it has not been shimmered to a + # different intrep when that is not necessary. + # Whether or not there is a string rep - we should not care! tcl::unsupported::representation $x -} -match glob -result {value is a dict with *, string representation "*"} +} -match glob -result {value is a dict *} # cleanup catch {unset a} diff --git a/tests/get.test b/tests/get.test index d51ec6d..d6a7206 100644 --- a/tests/get.test +++ b/tests/get.test @@ -19,9 +19,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} { 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}] - + test get-1.1 {Tcl_GetInt procedure} testgetint { testgetint 44 { 22} } {66} @@ -95,7 +96,24 @@ test get-3.2 {Tcl_GetDouble(FromObj), bad numbers} { } set result } {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 " " 007 " " 0o10 " " 0b10 "} { + catch {testgetint 44 $x} x + set x + } +} {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 " "07" "- 0" "-0" "0o12" "0b10"} { + catch {testdoubleobj set 1 $x} x + set x + } +} {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 return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/history.test b/tests/history.test index c562796..9ff41f2 100644 --- a/tests/history.test +++ b/tests/history.test @@ -10,9 +10,9 @@ # # 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 + +if {"::tcltest" ni [namespace children]} { + package require tcltest 2 namespace import -force ::tcltest::* } @@ -233,6 +233,7 @@ if {[testConstraint history]} { test history-8.1 {clear option} history {catch {history clear junk}} 1 test history-8.2 {clear option} history {history clear} {} if {[testConstraint history]} { + history clear history add "Testing" } test history-8.3 {clear option} history {history} { 1 Testing} @@ -244,7 +245,65 @@ test history-9.2 {miscellaneous} history { catch {history gorp} msg set msg } {unknown or ambiguous subcommand "gorp": must be add, change, clear, event, info, keep, nextid, or redo} + +# History retains references; Bug 1ae12987cb +test history-10.1 {references kept by history} -constraints history -setup { + interp create histtest + histtest eval { + # Trigger any autoloading that might be present + catch {history} + proc refcount {x} { + set rep [::tcl::unsupported::representation $x] + regexp {with a refcount of (\d+)} $rep -> rc + # Ignore the references due to calling this procedure + return [expr {$rc - 3}] + } + } +} -body { + histtest eval { + # A fresh object, refcount 1 from the variable we write it to + set obj [expr rand()] + set baseline [refcount $obj] + lappend result [refcount $obj] + history add [list list $obj] + lappend result [refcount $obj] + history clear + lappend result [refcount $obj] + } +} -cleanup { + interp delete histtest +} -result {1 2 1} +test history-10.2 {references kept by history} -constraints history -setup { + interp create histtest + histtest eval { + # Trigger any autoloading that might be present + catch {history} + proc refcount {x} { + set rep [::tcl::unsupported::representation $x] + regexp {with a refcount of (\d+)} $rep -> rc + # Ignore the references due to calling this procedure + return [expr {$rc - 3}] + } + } +} -body { + histtest eval { + # A fresh object, refcount 1 from the variable we write it to + set obj [expr rand()] + set baseline [refcount $obj] + lappend result [refcount $obj] + history add [list list $obj] + lappend result [refcount $obj] + rename history {} + lappend result [refcount $obj] + } +} -cleanup { + interp delete histtest +} -result {1 2 1} # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/http.test b/tests/http.test index 41820cb..75c963d 100644 --- a/tests/http.test +++ b/tests/http.test @@ -36,7 +36,6 @@ proc bgerror {args} { puts stderr $errorInfo } -set port 8010 set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null" catch {unset data} @@ -55,9 +54,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]} { @@ -69,10 +67,8 @@ 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] } } @@ -133,6 +129,7 @@ set tail /a/b/c set url //[info hostname]:$port/a/b/c set fullurl HTTP://user:pass@[info hostname]:$port/a/b/c set binurl //[info hostname]:$port/binary +set xmlurl //[info hostname]:$port/xml set posturl //[info hostname]:$port/post set badposturl //[info hostname]:$port/droppost set authorityurl //[info hostname]:$port @@ -431,6 +428,13 @@ Accept text/plain,application/tcl-test-value Accept-Encoding .* Content-Type application/x-www-form-urlencoded Content-Length 5} +# Bug 838e99a76d +test http-3.33 {http::geturl application/xml is text} -body { + set token [http::geturl "$xmlurl"] + scan [http::data $token] "<%\[^>]>%c<%\[^>]>" +} -cleanup { + catch { http::cleanup $token } +} -result {test 4660 /test} test http-4.1 {http::Event} -body { set token [http::geturl $url -keepalive 0] diff --git a/tests/httpd b/tests/httpd index 232e80a..f15d71b 100644 --- a/tests/httpd +++ b/tests/httpd @@ -11,7 +11,12 @@ #set httpLog 1 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 @@ -171,6 +176,10 @@ proc httpdRespond { sock } { set html "$bindata[info hostname]:$port$data(url)" set type application/octet-stream } + *xml* { + set html [encoding convertto utf-8 "<test>\u1234</test>"] + set type "application/xml;charset=UTF-8" + } *post* { set html "Got [string length $data(query)] bytes" set type text/plain @@ -205,7 +214,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/httpd11.tcl b/tests/httpd11.tcl index 6eae2b7..7880494 100644 --- a/tests/httpd11.tcl +++ b/tests/httpd11.tcl @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require Tcl 8.6 +package require Tcl 8.6- proc ::tcl::dict::get? {dict key} { if {[dict exists $dict $key]} { diff --git a/tests/httpold.test b/tests/httpold.test index aeba311..ab26613 100644 --- a/tests/httpold.test +++ b/tests/httpold.test @@ -1,3 +1,4 @@ +# -*- tcl -*- # Commands covered: http_config, http_get, http_wait, http_reset # # This file contains a collection of tests for the http script library. @@ -36,15 +37,14 @@ if {[catch {package require http 1.0}]} { 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] { +if [catch {httpd_init 0} listen] { puts "Cannot start http server, http test skipped" - unset port + catch {unset port} ::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 3057dd2..fd89b47 100644 --- a/tests/info.test +++ b/tests/info.test @@ -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"} @@ -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 { @@ -2398,6 +2398,23 @@ test info-33.35 {{*}, literal, simple, bytecompiled} -body { # ------------------------------------------------------------------------- unset -nocomplain res +test info-39.0 {Bug 4b61afd660} -setup { + proc probe {} { + return [dict get [info frame -1] line] + } + set body { + set cmd probe + $cmd + } + proc demo {} $body +} -body { + demo +} -cleanup { + unset -nocomplain body + rename demo {} + rename probe {} +} -result 3 + # cleanup catch {namespace delete test_ns_info1 test_ns_info2} ::tcltest::cleanupTests diff --git a/tests/init.test b/tests/init.test index 41b8624..0241283 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 4bc9fe2..1389304 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: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: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} 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,10 +70,12 @@ test interp-2.2 {basic interpreter creation} { } 0 test interp-2.3 {basic interpreter creation} { catch {interp create -safe} -} 0 -test interp-2.4 {basic interpreter creation} { - list [catch {interp create a} msg] $msg -} {1 {interpreter named "a" already exists, cannot create}} +} 0 +test interp-2.4 {basic interpreter creation} -setup { + catch {interp create a} +} -returnCodes error -body { + interp create a +} -result {interpreter named "a" already exists, cannot create} test interp-2.5 {basic interpreter creation} { interp create b -safe } b @@ -89,11 +91,13 @@ test interp-2.8 {basic interpreter creation} { test interp-2.9 {basic interpreter creation} { interp create -safe -- -froboz1 } -froboz1 -test interp-2.10 {basic interpreter creation} { +test interp-2.10 {basic interpreter creation} -setup { + catch {interp create a} +} -body { interp create {a x1} interp create {a x2} interp create {a x3} -safe -} {a x3} +} -result {a x3} test interp-2.11 {anonymous interps vs existing procs} { set x [interp create] regexp "interp(\[0-9]+)" $x dummy thenum @@ -102,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 @@ -140,19 +144,26 @@ test interp-3.5 {testing interp exists and interp slaves} -body { test interp-3.6 {testing interp exists and interp slaves} { interp exists } 1 -test interp-3.7 {testing interp exists and interp slaves} { +test interp-3.7 {testing interp exists and interp slaves} -setup { + catch {interp create a} +} -body { interp slaves -} a +} -result a test interp-3.8 {testing interp exists and interp slaves} -body { interp slaves a b c } -returnCodes error -result {wrong # args: should be "interp slaves ?path?"} -test interp-3.9 {testing interp exists and interp slaves} { +test interp-3.9 {testing interp exists and interp slaves} -setup { + catch {interp create a} +} -body { interp create {a a2} -safe expr {"a2" in [interp slaves a]} -} 1 -test interp-3.10 {testing interp exists and interp slaves} { +} -result 1 +test interp-3.10 {testing interp exists and interp slaves} -setup { + catch {interp create a} + catch {interp create {a a2}} +} -body { interp exists {a a2} -} 1 +} -result 1 # Part 3: Testing "interp delete" test interp-3.11 {testing interp delete} { @@ -222,6 +233,7 @@ test interp-6.3 {testing eval} { a eval {proc foo {} {expr 3 + 5}} a eval foo } 8 +catch {a eval {proc foo {} {expr 3 + 5}}} test interp-6.4 {testing eval} { interp eval a foo } 8 @@ -230,6 +242,7 @@ test interp-6.5 {testing eval} { interp eval {a x2} {proc frob {} {expr 4 * 9}} interp eval {a x2} frob } 36 +catch {interp create {a x2}} test interp-6.6 {testing eval} -returnCodes error -body { interp eval {a x2} foo } -result {invalid command name "foo"} @@ -243,9 +256,11 @@ proc in_master {args} { test interp-7.1 {testing basic alias creation} { a alias foo in_master } foo +catch {a alias foo in_master} test interp-7.2 {testing basic alias creation} { a alias bar in_master a1 a2 a3 } bar +catch {a alias bar in_master a1 a2 a3} # Test 6.3 has been deleted. test interp-7.3 {testing basic alias creation} { a alias foo @@ -476,9 +491,13 @@ test interp-13.4 {testing issafe arg checking} { } {1 {wrong # args: should be "a issafe"}} # part 14: testing interp aliases -test interp-14.1 {testing interp aliases} { - interp aliases -} "" +test interp-14.1 {testing interp aliases} -setup { + interp create abc +} -body { + interp eval abc {interp aliases} +} -cleanup { + interp delete abc +} -result "" test interp-14.2 {testing interp aliases} { catch {interp delete a} interp create a @@ -587,6 +606,19 @@ test interp-14.10 {testing interp-alias: error messages} -setup { invoked from within "a 1"} +test interp-14.11 {{interp alias} {target named the empty string} {bug 2bf56185}} -setup { + set interp [interp create [info cmdcount]] + interp eval $interp { + proc {} args {return $args} + } + +} -body { + interp alias {} p1 $interp {} + p1 one two three +} -cleanup { + interp delete $interp +} -result {one two three} + # part 15: testing file sharing test interp-15.1 {testing file sharing} { catch {interp delete z} @@ -844,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 @@ -939,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] @@ -1160,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 @@ -1169,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 @@ -1178,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 @@ -1188,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 @@ -1207,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 @@ -1218,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 @@ -1229,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 @@ -1240,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 @@ -1252,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 @@ -1264,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 @@ -1644,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 "" @@ -2168,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] } @@ -2182,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] } @@ -2196,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] } @@ -2212,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] } @@ -3289,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] @@ -3523,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 783bc75..6e7420d 100644 --- a/tests/io.test +++ b/tests/io.test @@ -44,6 +44,7 @@ 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 # particular, many file systems do not support large-files... @@ -123,10 +124,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" @@ -192,7 +193,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" @@ -214,7 +215,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" @@ -234,7 +235,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" @@ -256,7 +257,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" @@ -268,7 +269,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 @@ -280,7 +281,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 @@ -311,7 +312,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 @@ -381,7 +382,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 @@ -470,7 +471,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 @@ -769,7 +770,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" @@ -781,8 +782,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" @@ -889,7 +890,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] @@ -898,7 +899,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 @@ -906,7 +907,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] @@ -959,10 +960,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" @@ -975,7 +976,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" @@ -986,8 +987,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" @@ -999,7 +1000,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" @@ -1092,7 +1093,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" @@ -1201,7 +1202,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} { @@ -1217,7 +1218,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 @@ -1574,7 +1575,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 @@ -1587,7 +1588,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 @@ -1600,7 +1601,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 @@ -1715,7 +1716,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 @@ -2064,7 +2065,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]] @@ -2159,7 +2160,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. @@ -3057,7 +3058,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) @@ -3985,7 +3986,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 @@ -4285,6 +4286,13 @@ test io-33.4 {Tcl_Gets with long line} { close $f set x } {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ} +set f [open $path(test3) w] +puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" +close $f test io-33.5 {Tcl_Gets with long line} { set f [open $path(test3)] set x [gets $f y] @@ -5467,7 +5475,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] @@ -7141,7 +7149,12 @@ test io-52.10 {TclCopyChannel & encodings} {fcopy} { file size $path(utf8-fcopy.txt) } 5 -test io-52.11 {TclCopyChannel & encodings} {fcopy} { +test io-52.11 {TclCopyChannel & encodings} -setup { + set out [open $path(utf8-fcopy.txt) w] + fconfigure $out -encoding utf-8 -translation lf + puts $out "\u0410\u0410" + close $out +} -constraints {fcopy} -body { # binary to encoding => the input has to be # in utf-8 to make sense to the encoder @@ -7157,7 +7170,7 @@ test io-52.11 {TclCopyChannel & encodings} {fcopy} { close $out file size $path(kyrillic.txt) -} 3 +} -result 3 test io-52.12 {coverage of -translation auto} { file delete $path(test1) $path(test2) @@ -8003,191 +8016,6 @@ test io-53.17 {[7c187a3773] MBWrite: proper inQueueTail handling} -setup { close $c removeFile out } -result {line 100 line} -test io-53.18 {[32ae34e63a] recursive CopyData} -setup { - proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [encoding convertto utf-8 \ - [string repeat a 100]] - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch { - if {"read" in [lindex $args 1]} { - chan postevent $chan read - } - return - } - read { - set n [lindex $args 1] - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } - } - proc more {c outChan bytes args} { - if {[eof $c]} { - set ::done eof - catch {close $c} - return - } - if {[llength $args]} { - set ::done error - } else { - chan copy $c $outChan -command [list [namespace which more] $c $outChan] - } - } - set c [chan create read [namespace which driver]] - chan configure $c -encoding utf-8 - set out [makeFile {} out] - set outChan [open $out w] - # Different encoding to force use of DoReadChars() - chan configure $outChan -encoding iso8859-1 -} -body { - after 100 {set ::done timeout} - chan copy $c $outChan -size 99 -command [list [namespace which more] $c $outChan] - vwait ::done - set ::done -} -cleanup { - close $outChan - removeFile out - rename driver {} - rename more {} - unset ::done -} -result eof - -test io-53.19 {[32ae34e63a] stop ReflectWatch filtering} -setup { - proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [encoding convertto utf-8 \ - [string repeat a 100]] - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch { - if {"read" in [lindex $args 1]} { - chan postevent $chan read - } - return - } - read { - set n [lindex $args 1] - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } - } - proc more {c outChan bytes args} { - if {[eof $c]} { - set ::done eof - catch {close $c} - return - } - if {[llength $args]} { - set ::done error - } else { - chan copy $c $outChan -size 30 -command [list [namespace which more] $c $outChan] - } - } - set c [chan create read [namespace which driver]] - chan configure $c -encoding utf-8 -buffersize 20 - set out [makeFile {} out] - set outChan [open $out w] - # Different encoding to force use of DoReadChars() - chan configure $outChan -encoding iso8859-1 -} -body { - after 100 {set ::done timeout} - chan copy $c $outChan -size 30 -command [list [namespace which more] $c $outChan] - vwait ::done - set ::done -} -cleanup { - catch {close $outChan} - removeFile out - rename driver {} - rename more {} - unset ::done -} -result eof - -test io-53.20 {[e0a7b3e5f8] DoRead calls to UpdateInterest} -constraints knownBug -setup { - proc driver {cmd args} { - variable buffer - variable index - set chan [lindex $args 0] - switch -- $cmd { - initialize { - set index($chan) 0 - set buffer($chan) [encoding convertto utf-8 \ - [string repeat a 100]] - return {initialize finalize watch read} - } - finalize { - unset index($chan) buffer($chan) - return - } - watch { - if {"read" in [lindex $args 1]} { - chan postevent $chan read - } - return - } - read { - set n [lindex $args 1] - set new [expr {$index($chan) + $n}] - set result [string range $buffer($chan) $index($chan) $new-1] - set index($chan) $new - return $result - } - } - } - proc more {c outChan bytes args} { - if {[eof $c]} { - set ::done eof - catch {close $c} - return - } - if {[llength $args]} { - set ::done error - } else { - chan copy $c $outChan -size 10 -command [list [namespace which more] $c $outChan] - } - } - set c [chan create read [namespace which driver]] - chan configure $c -encoding utf-8 -buffersize 20 - set out [makeFile {} out] - set outChan [open $out w] - # Same encoding to force use of DoRead() - chan configure $outChan -encoding utf-8 -} -body { - after 100 {set ::done timeout} - chan copy $c $outChan -size 10 -command [list [namespace which more] $c $outChan] - vwait ::done - set ::done -} -cleanup { - catch {close $outChan} - removeFile out - rename driver {} - rename more {} - unset ::done -} -result eof test io-54.1 {Recursive channel events} {socket fileevent} { # This test checks to see if file events are delivered during recursive @@ -8811,6 +8639,24 @@ test io-73.5 {effect of eof on encoding end flags} -setup { removeFile io-73.5 } -result [list 1 1 more\u00a0data 1] +test io-74.1 {[104f2885bb] improper cache validity check} -setup { + set fn [makeFile {} io-74.1] + set rfd [open $fn r] + testobj freeallvars + interp create slave +} -constraints testobj -body { + teststringobj set 1 [string range $rfd 0 end] + read [teststringobj get 1] + testobj duplicate 1 2 + interp transfer {} $rfd slave + catch {read [teststringobj get 1]} + read [teststringobj get 2] +} -cleanup { + interp delete slave + testobj freeallvars + removeFile io-74.1 +} -returnCodes error -match glob -result {can not find channel named "*"} + # ### ### ### ######### ######### ######### # cleanup diff --git a/tests/ioCmd.test b/tests/ioCmd.test index f66480a..cd89a02 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -1019,7 +1019,7 @@ test iocmd-23.1 {chan read, regular data return} -match glob -body { close $c rename foo {} set res -} -result {{read rc* 4096} {read rc* 4096} {watch rc* {}} snarfsnarf} +} -result {{read rc* 4096} {read rc* 4096} snarfsnarf} test iocmd-23.2 {chan read, bad data return, to much} -match glob -body { set res {} proc foo {args} { @@ -1031,7 +1031,7 @@ test iocmd-23.2 {chan read, bad data return, to much} -match glob -body { close $c rename foo {} set res -} -result {{read rc* 4096} {watch rc* {}} 1 {read delivered more than requested}} +} -result {{read rc* 4096} 1 {read delivered more than requested}} test iocmd-23.3 {chan read, for non-readable channel} -match glob -body { set res {} proc foo {args} { @@ -1054,7 +1054,7 @@ test iocmd-23.4 {chan read, error return} -match glob -body { close $c rename foo {} set res -} -result {{read rc* 4096} {watch rc* {}} 1 BOOM!} +} -result {{read rc* 4096} 1 BOOM!} test iocmd-23.5 {chan read, break return is error} -match glob -body { set res {} proc foo {args} { @@ -1066,7 +1066,7 @@ test iocmd-23.5 {chan read, break return is error} -match glob -body { close $c rename foo {} set res -} -result {{read rc* 4096} {watch rc* {}} 1 *bad code*} +} -result {{read rc* 4096} 1 *bad code*} test iocmd-23.6 {chan read, continue return is error} -match glob -body { set res {} proc foo {args} { @@ -1078,7 +1078,7 @@ test iocmd-23.6 {chan read, continue return is error} -match glob -body { close $c rename foo {} set res -} -result {{read rc* 4096} {watch rc* {}} 1 *bad code*} +} -result {{read rc* 4096} 1 *bad code*} test iocmd-23.7 {chan read, custom return is error} -match glob -body { set res {} proc foo {args} { @@ -1090,7 +1090,7 @@ test iocmd-23.7 {chan read, custom return is error} -match glob -body { close $c rename foo {} set res -} -result {{read rc* 4096} {watch rc* {}} 1 *bad code*} +} -result {{read rc* 4096} 1 *bad code*} test iocmd-23.8 {chan read, level is squashed} -match glob -body { set res {} proc foo {args} { @@ -1102,7 +1102,7 @@ test iocmd-23.8 {chan read, level is squashed} -match glob -body { close $c rename foo {} set res -} -result {{read rc* 4096} {watch rc* {}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} +} -result {{read rc* 4096} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} test iocmd-23.9 {chan read, no data means eof} -match glob -setup { set res {} proc foo {args} { @@ -1118,7 +1118,7 @@ test iocmd-23.9 {chan read, no data means eof} -match glob -setup { close $c rename foo {} unset res -} -result {{read rc* 4096} {watch rc* {}} {} 1} +} -result {{read rc* 4096} {} 1} test iocmd-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glob -setup { set res {} proc foo {args} { @@ -1134,7 +1134,7 @@ test iocmd-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glo close $c rename foo {} unset res -} -result {{read rc* 4096} {watch rc* {}} {} 0} +} -result {{read rc* 4096} {} 0} test iocmd-23.11 {chan read, close pulls the rug out} -match glob -body { set res {} proc foo {args} { @@ -1448,14 +1448,14 @@ test iocmd-25.10 {chan configure, cgetall, level is ignored} -match glob -body { test iocmd-26.1 {chan configure, set standard option} -match glob -body { set res {} proc foo {args} { - oninit configure; onfinal; track; return + oninit configure; onfinal; track; note MUST_NOT_HAPPEN; return } set c [chan create {r w} foo] note [fconfigure $c -translation lf] close $c rename foo {} set res -} -result {{watch rc* {}} {}} +} -result {{}} test iocmd-26.2 {chan configure, set option, error return} -match glob -body { set res {} proc foo {args} { @@ -1993,7 +1993,7 @@ test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body { close $c rename foo {} set res -} -result {{watch rc* read} {} TOCK {watch rc* read} {} {watch rc* {}}} +} -result {{watch rc* read} {} TOCK {} {watch rc* {}}} test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body { set res {} proc foo {args} {oninit; onfinal; track; return} @@ -2006,7 +2006,7 @@ test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body { close $c rename foo {} set res -} -result {{watch rc* write} {} TOCK {watch rc* write} {} {watch rc* {}}} +} -result {{watch rc* write} {} TOCK {} {watch rc* {}}} test iocmd-31.8 {chan postevent after close throws error} -match glob -setup { proc foo {args} {oninit; onfinal; track; return} proc dummy args { return } @@ -2300,7 +2300,7 @@ test iocmd.tf-23.1 {chan read, regular data return} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel thread} -result {{read rc* 4096} {read rc* 4096} {watch rc* {}} snarfsnarf} +} -constraints {testchannel thread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf} test iocmd.tf-23.2 {chan read, bad data return, to much} -match glob -body { set res {} proc foo {args} { @@ -2315,7 +2315,7 @@ test iocmd.tf-23.2 {chan read, bad data return, to much} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel thread} -result {{read rc* 4096} {watch rc* {}} 1 {read delivered more than requested}} +} -constraints {testchannel thread} -result {{read rc* 4096} 1 {read delivered more than requested}} test iocmd.tf-23.3 {chan read, for non-readable channel} -match glob -body { set res {} proc foo {args} { @@ -2344,7 +2344,7 @@ test iocmd.tf-23.4 {chan read, error return} -match glob -body { } c] rename foo {} set res -} -result {{read rc* 4096} {watch rc* {}} 1 BOOM!} \ +} -result {{read rc* 4096} 1 BOOM!} \ -constraints {testchannel thread} test iocmd.tf-23.5 {chan read, break return is error} -match glob -body { set res {} @@ -2360,7 +2360,7 @@ test iocmd.tf-23.5 {chan read, break return is error} -match glob -body { } c] rename foo {} set res -} -result {{read rc* 4096} {watch rc* {}} 1 *bad code*} \ +} -result {{read rc* 4096} 1 *bad code*} \ -constraints {testchannel thread} test iocmd.tf-23.6 {chan read, continue return is error} -match glob -body { set res {} @@ -2376,7 +2376,7 @@ test iocmd.tf-23.6 {chan read, continue return is error} -match glob -body { } c] rename foo {} set res -} -result {{read rc* 4096} {watch rc* {}} 1 *bad code*} \ +} -result {{read rc* 4096} 1 *bad code*} \ -constraints {testchannel thread} test iocmd.tf-23.7 {chan read, custom return is error} -match glob -body { set res {} @@ -2392,7 +2392,7 @@ test iocmd.tf-23.7 {chan read, custom return is error} -match glob -body { } c] rename foo {} set res -} -result {{read rc* 4096} {watch rc* {}} 1 *bad code*} \ +} -result {{read rc* 4096} 1 *bad code*} \ -constraints {testchannel thread} test iocmd.tf-23.8 {chan read, level is squashed} -match glob -body { set res {} @@ -2408,7 +2408,7 @@ test iocmd.tf-23.8 {chan read, level is squashed} -match glob -body { } c] rename foo {} set res -} -result {{read rc* 4096} {watch rc* {}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} \ +} -result {{read rc* 4096} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} \ -constraints {testchannel thread} test iocmd.tf-23.9 {chan read, no data means eof} -match glob -setup { set res {} @@ -2428,7 +2428,7 @@ test iocmd.tf-23.9 {chan read, no data means eof} -match glob -setup { } -cleanup { rename foo {} unset res -} -result {{read rc* 4096} {watch rc* {}} {} 1} \ +} -result {{read rc* 4096} {} 1} \ -constraints {testchannel thread} test iocmd.tf-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glob -setup { set res {} @@ -2448,7 +2448,7 @@ test iocmd.tf-23.10 {chan read, EAGAIN means no data, yet no eof either} -match } -cleanup { rename foo {} unset res -} -result {{read rc* 4096} {watch rc* {}} {} 0} \ +} -result {{read rc* 4096} {} 0} \ -constraints {testchannel thread} # --- === *** ########################### @@ -3001,7 +3001,7 @@ test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -bod test iocmd.tf-26.1 {chan configure, set standard option} -match glob -body { set res {} proc foo {args} { - oninit configure; onfinal; track; return + oninit configure; onfinal; track; note MUST_NOT_HAPPEN; return } set c [chan create {r w} foo] notes [inthread $c { @@ -3011,7 +3011,7 @@ test iocmd.tf-26.1 {chan configure, set standard option} -match glob -body { } c] rename foo {} set res -} -constraints {testchannel thread} -result {{watch rc* {}} {}} +} -constraints {testchannel thread} -result {{}} test iocmd.tf-26.2 {chan configure, set option, error return} -match glob -body { set res {} proc foo {args} { diff --git a/tests/ioTrans.test b/tests/ioTrans.test index e179eab..63a609f 100644 --- a/tests/ioTrans.test +++ b/tests/ioTrans.test @@ -1318,7 +1318,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..aa579bf 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. diff --git a/tests/lindex.test b/tests/lindex.test index b86e2e0..29eb898 100644 --- a/tests/lindex.test +++ b/tests/lindex.test @@ -432,7 +432,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 +441,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 00e490c..dda7d6b 100644 --- a/tests/link.test +++ b/tests/link.test @@ -89,6 +89,90 @@ test link-2.5 {writing bad values into variables} -setup { testlink create 1 1 1 1 1 1 1 1 1 1 1 1 1 1 list [catch {set wide gorp} msg] $msg $bool } -result {1 {can't set "wide": variable must have integer value} 1} +test link-2.6 {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 "+" + set real "+" + set bool 1 + set string "+" + set wide "+" + set char "+" + set uchar "+" + set short "+" + set ushort "+" + set uint "+" + set long "+" + set ulong "+" + set float "+" + set uwide "+" + concat [testlink get] | $int $real $bool $string $wide $char $uchar $short $ushort $uint $long $ulong $float $uwide +} -result {1 1.0 1 + 1 1 1 1 1 1 1 1 1.0 1 | + + 1 + + + + + + + + + + +} +test link-2.7 {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 "-" + set real "-" + set bool 0 + set string "-" + set wide "-" + set char "-" + set uchar "-" + set short "-" + set ushort "-" + set uint "-" + set long "-" + set ulong "-" + set float "-" + set uwide "-" + 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 - - - - - - - - - - -} +test link-2.8 {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 "0O" + set char "0X" + set uchar "0B" + set short "0O" + set ushort "0x" + set uint "0b" + set long "0o" + set ulong "0X" + set float "0B" + set uwide "0O" + 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 0O 0X 0B 0O 0x 0b 0o 0X 0B 0O} +test link-2.8 {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 0 + set real 5000e + set bool 0 + set string 0 + set wide 0 + set char 0 + set uchar 0 + set short 0 + set ushort 0 + set uint 0 + set long 0 + set ulong 0 + set float -60.00e+ + 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-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/load.test b/tests/load.test index 9536271..4cd1fcd 100644 --- a/tests/load.test +++ b/tests/load.test @@ -124,9 +124,11 @@ test load-3.2 {error in _Init procedure, slave interpreter} \ test load-4.1 {reloading package into same interpreter} [list $dll $loaded] { list [catch {load [file join $testDir pkga$ext] pkga} msg] $msg } {0 {}} -test load-4.2 {reloading package into same interpreter} [list $dll $loaded] { - list [catch {load [file join $testDir pkga$ext] pkgb} msg] $msg -} [list 1 "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\""] +test load-4.2 {reloading package into same interpreter} -setup { + catch {load [file join $testDir pkga$ext] pkga} +} -constraints [list $dll $loaded] -returnCodes error -body { + load [file join $testDir pkga$ext] pkgb +} -result "file \"[file join $testDir pkga$ext]\" is already loaded for package \"Pkga\"" test load-5.1 {file name not specified and no static package: pick default} \ [list $dll $loaded] { @@ -169,26 +171,47 @@ test load-7.3 {Tcl_StaticPackage procedure} [list teststaticpkg] { load {} More set x } {not loaded} -test load-7.4 {Tcl_StaticPackage procedure, redundant calls} \ - [list teststaticpkg $dll $loaded] { - teststaticpkg Double 0 1 - teststaticpkg Double 0 1 - info loaded - } [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] $alreadyTotalLoaded] - -test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] { +catch {load [file join $testDir pkga$ext] pkga} +catch {load [file join $testDir pkgb$ext] pkgb} +catch {load [file join $testDir pkge$ext] pkge} +set currentRealPackages [list [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] +test load-7.4 {Tcl_StaticPackage procedure, redundant calls} -setup { + teststaticpkg Test 1 0 + teststaticpkg Another 0 0 + teststaticpkg More 0 1 +} -constraints [list teststaticpkg $dll $loaded] -body { + teststaticpkg Double 0 1 + teststaticpkg Double 0 1 info loaded -} [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkge$ext] Pkge] [list [file join $testDir pkgb$ext] Pkgb] [list [file join $testDir pkga$ext] Pkga]] $alreadyTotalLoaded] -test load-8.2 {TclGetLoadedPackages procedure} [list teststaticpkg] { - list [catch {info loaded gorp} msg] $msg -} {1 {could not find interpreter "gorp"}} -test load-8.3 {TclGetLoadedPackages procedure} [list teststaticpkg $dll $loaded] { - list [info loaded {}] [info loaded child] -} [list [concat [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]] -test load-8.4 {TclGetLoadedPackages procedure} [list $dll $loaded teststaticpkg] { +} -result [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded] + +testConstraint teststaticpkg_8.x \ + [if {[testConstraint teststaticpkg]} { + teststaticpkg Test 1 1 + teststaticpkg Another 0 1 + teststaticpkg More 0 1 + teststaticpkg Double 0 1 + expr 1 + } else { + expr 0 + }] + +test load-8.1 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { + lsort -index 1 [info loaded] +} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} {*}$currentRealPackages {*}$alreadyTotalLoaded]] +test load-8.2 {TclGetLoadedPackages procedure} -constraints {teststaticpkg_8.x} -body { + info loaded gorp +} -returnCodes error -result {could not find interpreter "gorp"} +test load-8.3a {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { + lsort -index 1 [info loaded {}] +} [lsort -index 1 [list {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga] [list [file join $testDir pkgb$ext] Pkgb] {*}$alreadyLoaded]] +test load-8.3b {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { + lsort -index 1 [info loaded child] +} [lsort -index 1 [list {{} Test} [list [file join $testDir pkgb$ext] Pkgb]]] +test load-8.4 {TclGetLoadedPackages procedure} [list teststaticpkg_8.x $dll $loaded] { load [file join $testDir pkgb$ext] pkgb - list [info loaded {}] [lsort [info commands pkgb_*]] -} [list [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded] {pkgb_demo pkgb_sub pkgb_unsafe}] + list [lsort -index 1 [info loaded {}]] [lsort [info commands pkgb_*]] +} [list [lsort -index 1 [concat [list [list [file join $testDir pkgb$ext] Pkgb] {{} Double} {{} More} {{} Another} {{} Test} [list [file join $testDir pkga$ext] Pkga]] $alreadyLoaded]] {pkgb_demo pkgb_sub pkgb_unsafe}] interp delete child test load-9.1 {Tcl_StaticPackage, load already-loaded package into another interp} \ diff --git a/tests/lrange.test b/tests/lrange.test index 17a757e..02b9c65 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} { 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 e66a331..d7f8226 100644 --- a/tests/lreplace.test +++ b/tests/lreplace.test @@ -98,7 +98,12 @@ 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} { + lreplace x 1 1 +} x +test lreplace-1.28 {lreplace command} { + lreplace x 1 1 y +} {x y} test lreplace-2.1 {lreplace errors} { list [catch lreplace msg] $msg @@ -119,8 +124,8 @@ test lreplace-2.6 {lreplace errors} { list [catch {lreplace x 3 2} msg] $msg } {1 {list doesn't contain element 3}} test lreplace-2.7 {lreplace errors} { - list [catch {lreplace x 1 1} msg] $msg -} {1 {list doesn't contain element 1}} + list [catch {lreplace x 2 2} msg] $msg +} {1 {list doesn't contain element 2}} test lreplace-3.1 {lreplace won't modify shared argument objects} { proc p {} { @@ -181,6 +186,49 @@ test lreplace-4.11 {lreplace end index first} { test lreplace-4.12 {lreplace end index first} { lreplace {0 1 2 3 4} end-2 2 a b c } {0 1 a b c 3 4} +test lreplace-4.13 {lreplace empty list} { + lreplace {} 1 1 1 +} 1 +test lreplace-4.14 {lreplace empty list} { + lreplace {} 2 2 2 +} 2 + +test lreplace-5.1 {compiled lreplace: Bug 47ac84309b} { + apply {x { + lreplace $x end 0 + }} {a b c} +} {a b c} +test lreplace-5.2 {compiled lreplace: Bug 47ac84309b} { + apply {x { + lreplace $x end 0 A + }} {a b c} +} {a b A c} + +# Testing for compiled behaviour. Far too many variations to check with +# spelt-out tests. Note that this *just* checks whether the compiled version +# and the interpreted version are the same, not whether the interpreted +# version is correct. +apply {{} { + set lss {{} {a} {a b c} {a b c d}} + set ins {{} A {A B}} + set idxs {-2 -1 0 1 2 3 end-3 end-2 end-1 end end+1 end+2} + set lreplace lreplace + + foreach ls $lss { + foreach a $idxs { + foreach b $idxs { + foreach i $ins { + set expected [list [catch {$lreplace $ls $a $b {*}$i} m] $m] + set tester [list lreplace $ls $a $b {*}$i] + set script [list catch $tester m] + set script "list \[$script\] \$m" + test lreplace-6.[incr n] {lreplace battery} \ + [list apply [list {} $script]] $expected + } + } + } + } +}} # cleanup catch {unset foo} diff --git a/tests/lsearch.test b/tests/lsearch.test index f36e987..b2c1812 100644 --- a/tests/lsearch.test +++ b/tests/lsearch.test @@ -404,16 +404,16 @@ 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} @@ -426,11 +426,11 @@ 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} @@ -442,11 +442,11 @@ test lsearch-19.2 {lsearch -sunindices 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* + 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} { lsearch -subindices -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b} -} {0 0 1} +} {0 0 1} test lsearch-19.5 {lsearch -sunindices 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}} diff --git a/tests/lsetComp.test b/tests/lsetComp.test index 6846cbf..6330de4 100644 --- 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/main.test b/tests/main.test index 351fd4f..ab66b38 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 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 6b965d1..1c3ce58 100644 --- a/tests/msgcat.test +++ b/tests/msgcat.test @@ -12,7 +12,7 @@ # Note that after running these tests, entries will be left behind in the # message catalogs for locales foo, foo_BAR, and foo_BAR_baz. -package require Tcl 8.5 +package require Tcl 8.5- if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." return @@ -51,7 +51,7 @@ namespace eval ::msgcat::test { variable body variable result variable setVars - foreach setVars [PowerSet $envVars] { + foreach setVars [PowerSet $envVars] { set result [string tolower [lindex $setVars 0]] if {[string length $result] == 0} { if {[info exists ::tcl::mac::locale]} { @@ -68,6 +68,7 @@ namespace eval ::msgcat::test { set result c } } + test msgcat-0.$count [list \ locale initialization from environment variables $setVars \ ] -setup { @@ -93,7 +94,7 @@ namespace eval ::msgcat::test { incr count } unset -nocomplain result - + # Could add tests of initialization from Windows registry here. # Use a fake registry package. @@ -293,11 +294,11 @@ namespace eval ::msgcat::test { variable count 2 variable result array set result { - foo,ov0 ov0_ROOT foo,ov1 ov1_foo foo,ov2 ov2_foo + foo,ov0 ov0_ROOT foo,ov1 ov1_foo foo,ov2 ov2_foo foo,ov3 ov3_foo foo,ov4 ov4 - foo_BAR,ov0 ov0_ROOT foo_BAR,ov1 ov1_foo foo_BAR,ov2 ov2_foo_BAR - foo_BAR,ov3 ov3_foo_BAR foo_BAR,ov4 ov4 - foo_BAR_baz,ov0 ov0_ROOT foo_BAR_baz,ov1 ov1_foo + foo_BAR,ov0 ov0_ROOT foo_BAR,ov1 ov1_foo foo_BAR,ov2 ov2_foo_BAR + foo_BAR,ov3 ov3_foo_BAR foo_BAR,ov4 ov4 + foo_BAR_baz,ov0 ov0_ROOT foo_BAR_baz,ov1 ov1_foo foo_BAR_baz,ov2 ov2_foo_BAR foo_BAR_baz,ov3 ov3_foo_BAR_baz foo_BAR_baz,ov4 ov4 } @@ -416,12 +417,12 @@ namespace eval ::msgcat::test { variable locale [mclocale] ::msgcat::mclocale "" ::msgcat::mcloadedlocales clear - ::msgcat::mcpackageconfig unset mcfolder + ::msgcat::mcpackageconfig unset mcfolder mclocale $loc } -cleanup { mclocale $locale ::msgcat::mcloadedlocales clear - ::msgcat::mcpackageconfig unset mcfolder + ::msgcat::mcpackageconfig unset mcfolder } -body { mcload $msgdir } -result [expr { $count+1 }] @@ -436,7 +437,7 @@ namespace eval ::msgcat::test { } -cleanup { mclocale $locale mcloadedlocales clear - mcpackageconfig unset mcfolder + mcpackageconfig unset mcfolder } -body { mcload $msgdir } -result 3 @@ -447,7 +448,7 @@ namespace eval ::msgcat::test { } -cleanup { mclocale $locale mcloadedlocales clear - mcpackageconfig unset mcfolder + mcpackageconfig unset mcfolder } -body { mcload $msgdir } -result 1 @@ -516,7 +517,7 @@ namespace eval ::msgcat::test { } -cleanup { mclocale $locale mcloadedlocales clear - mcpackageconfig unset mcfolder + mcpackageconfig unset mcfolder } -body { mclocale foo mcpackageconfig set mcfolder $msgdir @@ -535,7 +536,7 @@ namespace eval ::msgcat::test { # Tests msgcat-6.*: [mcset], [mc] namespace inheritance # # Test mcset and mc, ensuring that resolution for messages -# proceeds from the current ns to its parent and so on to the +# proceeds from the current ns to its parent and so on to the # global ns. # # Do this for the 12 permutations of @@ -579,7 +580,7 @@ namespace eval ::msgcat::test { ::msgcat::mcset foo ov3 "ov3_foo_bar_baz" } } - + } variable locale [mclocale] mclocale foo @@ -688,12 +689,12 @@ namespace eval ::msgcat::test { mcexists } -returnCodes 1\ -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? src"} - + test msgcat-9.2 {mcexists unknown option} -body { - mcexists -unknown src + mcexists -unknown src } -returnCodes 1\ -result {unknown option "-unknown"} - + test msgcat-9.3 {mcexists} -setup { mcforgetpackage variable locale [mclocale] @@ -715,7 +716,7 @@ namespace eval ::msgcat::test { } -body { list [mcexists k1] [mcexists -exactlocale k1] } -result {1 0} - + test msgcat-9.5 {mcexists parent namespace} -setup { mcforgetpackage variable locale [mclocale] @@ -729,19 +730,19 @@ namespace eval ::msgcat::test { [::msgcat::mcexists -exactnamespace k1] } } -result {1 0} - + # Tests msgcat-10.*: [mcloadedlocales] test msgcat-10.1 {mcloadedlocales no arg} -body { mcloadedlocales } -returnCodes 1\ -result {wrong # args: should be "mcloadedlocales subcommand"} - + test msgcat-10.2 {mcloadedlocales wrong subcommand} -body { mcloadedlocales junk } -returnCodes 1\ -result {unknown subcommand "junk": must be clear, or loaded} - + test msgcat-10.3 {mcloadedlocales loaded} -setup { mcforgetpackage variable locale [mclocale] @@ -754,7 +755,7 @@ namespace eval ::msgcat::test { # The result is position independent so sort set resultlist [lsort [mcloadedlocales loaded]] } -result {{} foo foo_bar} - + test msgcat-10.4 {mcloadedlocales clear} -setup { mcforgetpackage variable locale [mclocale] @@ -960,9 +961,9 @@ namespace eval ::msgcat::test { } -result {0 0 1 0} # option mcfolder is already tested with 5.11 - + # Tests msgcat-14.*: callbacks: loadcmd, changecmd, unknowncmd - + # This routine is used as bgerror and by direct callback invocation proc callbackproc args { variable resultvariable @@ -973,7 +974,10 @@ namespace eval ::msgcat::test { } set bgerrorsaved [interp bgerror {}] interp bgerror {} [namespace code callbackproc] - + + variable locale + if {![info exist locale]} { set locale [mclocale] } + test msgcat-14.1 {invokation loadcmd} -setup { mcforgetpackage mclocale $locale @@ -995,6 +999,7 @@ namespace eval ::msgcat::test { mcloadedlocales clear } -cleanup { mcforgetpackage + after cancel set [namespace current]::resultvariable timeout } -body { mcpackageconfig set loadcmd [namespace code callbackfailproc] mclocale foo_bar @@ -1067,7 +1072,7 @@ namespace eval ::msgcat::test { mc k1 } -returnCodes 1\ -result {fail} - + interp bgerror {} $bgerrorsaved cleanupTests @@ -1075,3 +1080,6 @@ namespace eval ::msgcat::test { namespace delete ::msgcat::test return +# Local Variables: +# mode: tcl +# End: diff --git a/tests/namespace-old.test b/tests/namespace-old.test index 1d8ba31..1d6a805 100644 --- a/tests/namespace-old.test +++ b/tests/namespace-old.test @@ -57,6 +57,12 @@ test namespace-old-1.9 {add elements to a namespace} { } } } {} +namespace eval test_ns_simple { + variable test_ns_x 0 + proc test {test_ns_x} { + return "test: $test_ns_x" + } +} test namespace-old-1.10 {commands in a namespace} { namespace eval test_ns_simple { info commands [namespace current]::*} } {::test_ns_simple::test} @@ -74,6 +80,12 @@ test namespace-old-1.13 {add to an existing namespace} { } } } "" +namespace eval test_ns_simple { + variable test_ns_y 123 + proc _backdoor {cmd} { + eval $cmd + } +} test namespace-old-1.14 {commands in a namespace} { lsort [namespace eval test_ns_simple {info commands [namespace current]::*}] } {::test_ns_simple::_backdoor ::test_ns_simple::test} @@ -128,6 +140,8 @@ test namespace-old-1.26 {namespace qualifiers are okay after $'s} { test namespace-old-1.27 {can create commands with null names} { proc test_ns_simple:: {args} {return $args} } {} +# Redeclare; later tests depend on it +proc test_ns_simple:: {args} {return $args} # ----------------------------------------------------------------------- # TEST: using "info" in namespace contexts @@ -212,6 +226,11 @@ test namespace-old-4.3 {command "namespace delete" doesn't support patterns} { } list [catch $cmd msg] $msg } {1 {unknown namespace "ns*" in namespace delete command}} +namespace eval test_ns_delete { + namespace eval ns1 {} + namespace eval ns2 {} + namespace eval another {} +} test namespace-old-4.4 {command "namespace delete" handles multiple args} { set cmd { namespace eval test_ns_delete { @@ -256,6 +275,24 @@ test namespace-old-5.3 {namespace qualifiers work in namespace command} { [namespace eval test_ns_hier1::test_ns_hier2 {namespace current}] \ [namespace eval ::test_ns_hier1::test_ns_hier2 {namespace current}] } {::test_ns_hier1 ::test_ns_hier1::test_ns_hier2 ::test_ns_hier1::test_ns_hier2} +set ::test_ns_var_global "var in ::" +proc test_ns_cmd_global {} {return "cmd in ::"} +namespace eval test_ns_hier1 { + variable test_ns_var_hier1 "particular to hier1" + proc test_ns_cmd_hier1 {} {return "particular to hier1"} + variable test_ns_level 1 + proc test_ns_show {} {return "[namespace current]: 1"} + namespace eval test_ns_hier2 { + variable test_ns_var_hier2 "particular to hier2" + proc test_ns_cmd_hier2 {} {return "particular to hier2"} + variable test_ns_level 2 + proc test_ns_show {} {return "[namespace current]: 2"} + namespace eval test_ns_hier3a {} + namespace eval test_ns_hier3b {} + } + namespace eval test_ns_hier2a {} + namespace eval test_ns_hier2b {} +} test namespace-old-5.4 {nested namespaces can access global namespace} { list [namespace eval test_ns_hier1 {set test_ns_var_global}] \ [namespace eval test_ns_hier1 {test_ns_cmd_global}] \ @@ -331,16 +368,12 @@ test namespace-old-5.21 {querying namespace parent for explicit namespace} { # ----------------------------------------------------------------------- # TEST: name resolution and caching # ----------------------------------------------------------------------- +set trigger {namespace eval test_ns_cache2 {namespace current}} +set trigger2 {namespace eval test_ns_cache2::test_ns_cache3 {namespace current}} test namespace-old-6.1 {relative ns names only looked up in current ns} { namespace eval test_ns_cache1 {} namespace eval test_ns_cache2 {} namespace eval test_ns_cache2::test_ns_cache3 {} - set trigger { - namespace eval test_ns_cache2 {namespace current} - } - set trigger2 { - namespace eval test_ns_cache2::test_ns_cache3 {namespace current} - } list [namespace eval test_ns_cache1 $trigger] \ [namespace eval test_ns_cache1 $trigger2] } {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} @@ -354,20 +387,19 @@ test namespace-old-6.3 {relative ns names only looked up in current ns} { list [namespace eval test_ns_cache1 $trigger] \ [namespace eval test_ns_cache1 $trigger2] } {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} +namespace eval test_ns_cache1::test_ns_cache2 {} test namespace-old-6.4 {relative ns names only looked up in current ns} { namespace delete test_ns_cache1::test_ns_cache2 list [namespace eval test_ns_cache1 $trigger] \ [namespace eval test_ns_cache1 $trigger2] } {::test_ns_cache1::test_ns_cache2 ::test_ns_cache1::test_ns_cache2::test_ns_cache3} +namespace eval test_ns_cache1 { + proc trigger {} {test_ns_cache_cmd} +} test namespace-old-6.5 {define test commands} { proc test_ns_cache_cmd {} { return "global version" } - namespace eval test_ns_cache1 { - proc trigger {} { - test_ns_cache_cmd - } - } test_ns_cache1::trigger } {global version} test namespace-old-6.6 {one-level check for command shadowing} { @@ -376,24 +408,36 @@ test namespace-old-6.6 {one-level check for command shadowing} { } test_ns_cache1::trigger } {cache1 version} -test namespace-old-6.7 {renaming commands changes command epoch} { - namespace eval test_ns_cache1 { - rename test_ns_cache_cmd test_ns_new +proc test_ns_cache_cmd {} { + return "global version" +} +test namespace-old-6.7 {renaming commands changes command epoch} -setup { + proc test_ns_cache1::test_ns_cache_cmd {} { + return "cache1 version" } - test_ns_cache1::trigger -} {global version} -test namespace-old-6.8 {renaming back handles shadowing} { - namespace eval test_ns_cache1 { - rename test_ns_new test_ns_cache_cmd +} -body { + list [test_ns_cache1::trigger] \ + [namespace eval test_ns_cache1 {rename test_ns_cache_cmd test_ns_new}]\ + [test_ns_cache1::trigger] +} -result {{cache1 version} {} {global version}} +test namespace-old-6.8 {renaming back handles shadowing} -setup { + proc test_ns_cache1::test_ns_new {} { + return "cache1 version" } - test_ns_cache1::trigger -} {cache1 version} -test namespace-old-6.9 {deleting commands changes command epoch} { - namespace eval test_ns_cache1 { - rename test_ns_cache_cmd "" +} -body { + list [test_ns_cache1::trigger] \ + [namespace eval test_ns_cache1 {rename test_ns_new test_ns_cache_cmd}]\ + [test_ns_cache1::trigger] +} -result {{global version} {} {cache1 version}} +test namespace-old-6.9 {deleting commands changes command epoch} -setup { + proc test_ns_cache1::test_ns_cache_cmd {} { + return "cache1 version" } - test_ns_cache1::trigger -} {global version} +} -body { + list [test_ns_cache1::trigger] \ + [namespace eval test_ns_cache1 {rename test_ns_cache_cmd ""}] \ + [test_ns_cache1::trigger] +} -result {{cache1 version} {} {global version}} test namespace-old-6.10 {define test namespaces} { namespace eval test_ns_cache2 { proc test_ns_cache_cmd {} { @@ -412,6 +456,12 @@ test namespace-old-6.10 {define test namespaces} { } list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger] } {{global cache2 version} {global version}} +namespace eval test_ns_cache1 { + proc trigger {} { test_ns_cache2::test_ns_cache_cmd } + namespace eval test_ns_cache2 { + proc trigger {} { test_ns_cache_cmd } + } +} test namespace-old-6.11 {commands affect all parent namespaces} { proc test_ns_cache1::test_ns_cache2::test_ns_cache_cmd {} { return "cache2 version" @@ -423,18 +473,22 @@ test namespace-old-6.12 {define test variables} { set trigger {set test_ns_cache_var} namespace eval test_ns_cache1 $trigger } {global version} + set trigger {set test_ns_cache_var} test namespace-old-6.13 {one-level check for variable shadowing} { namespace eval test_ns_cache1 { variable test_ns_cache_var "cache1 version" } namespace eval test_ns_cache1 $trigger } {cache1 version} +variable ::test_ns_cache_var "global version" test namespace-old-6.14 {deleting variables changes variable epoch} { namespace eval test_ns_cache1 { - unset test_ns_cache_var + variable test_ns_cache_var "cache1 version" } - namespace eval test_ns_cache1 $trigger -} {global version} + list [namespace eval test_ns_cache1 $trigger] \ + [namespace eval test_ns_cache1 {unset test_ns_cache_var}] \ + [namespace eval test_ns_cache1 $trigger] +} {{cache1 version} {} {global version}} test namespace-old-6.15 {define test namespaces} { namespace eval test_ns_cache2 { variable test_ns_cache_var "global cache2 version" @@ -443,6 +497,7 @@ test namespace-old-6.15 {define test namespaces} { list [namespace eval test_ns_cache1 $trigger2] \ [namespace eval test_ns_cache1::test_ns_cache2 $trigger] } {{global cache2 version} {global version}} +set trigger2 {set test_ns_cache2::test_ns_cache_var} test namespace-old-6.16 {public variables affect all parent namespaces} { variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version" list [namespace eval test_ns_cache1 $trigger2] \ @@ -467,6 +522,7 @@ test namespace-old-6.19 {querying: namespace which -command} { test namespace-old-6.20 {command "namespace which" may not find commands} { namespace eval test_ns_cache1 {namespace which -command xyzzy} } {} +variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version" test namespace-old-6.21 {querying: namespace which -variable} { namespace eval test_ns_cache1::test_ns_cache2 { namespace which -variable test_ns_cache_var @@ -493,6 +549,18 @@ test namespace-old-7.1 {define test namespace} { } } } {} +namespace eval test_ns_uplevel { + variable x 0 + variable y 1 + proc show_vars {num} { + return [uplevel $num {info vars}] + } + proc test_uplevel {num} { + set a 0 + set b 1 + namespace eval ::test_ns_uplevel " return \[show_vars $num\] " + } +} test namespace-old-7.2 {uplevel can access namespace call frame} { list [expr {"x" in [test_ns_uplevel::test_uplevel 1]}] \ [expr {"y" in [test_ns_uplevel::test_uplevel 1]}] @@ -526,6 +594,17 @@ test namespace-old-7.8 {namespaces are included in the call stack} { } } } {} +namespace eval test_ns_upvar { + variable scope "test_ns_upvar" + proc show_val {var num} { + upvar $num $var x + return $x + } + proc test_upvar {num} { + set scope "test_ns_upvar::test_upvar" + namespace eval ::test_ns_upvar " return \[show_val scope $num\] " + } +} test namespace-old-7.9 {upvar can access namespace call frame} { test_ns_upvar::test_upvar 1 } {test_ns_upvar} @@ -581,6 +660,15 @@ test namespace-old-9.3 {define test namespaces for import} { } lsort [info commands test_ns_export::*] } {::test_ns_export::cmd1 ::test_ns_export::cmd2 ::test_ns_export::cmd3 ::test_ns_export::cmd4 ::test_ns_export::cmd5 ::test_ns_export::cmd6} +namespace eval test_ns_export { + namespace export cmd1 cmd2 cmd3 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} + proc cmd5 {args} {return "cmd5: $args"} + proc cmd6 {args} {return "cmd6: $args"} +} test namespace-old-9.4 {check export status} { set x "" namespace eval test_ns_import { @@ -592,6 +680,10 @@ test namespace-old-9.4 {check export status} { } set x } {::test_ns_import::cmd1 ::test_ns_import::cmd2 ::test_ns_import::cmd3} +namespace eval test_ns_import { + namespace export cmd1 cmd2 + namespace import ::test_ns_export::* +} test namespace-old-9.5 {empty import list in "namespace import" command} { namespace eval test_ns_import_empty { namespace import ::test_ns_export::* @@ -615,6 +707,7 @@ test namespace-old-9.8 {only exported commands are imported} { namespace import test_ns_import::cmd* set x [lsort [info commands cmd*]] } {cmd1 cmd2} +namespace import test_ns_import::cmd* test namespace-old-9.9 {imported commands work just the same as original} { list [cmd1 test 1 2 3] [test_ns_import::cmd1 test 4 5 6] } {{cmd1: test 1 2 3} {cmd1: test 4 5 6}} @@ -629,10 +722,19 @@ test namespace-old-9.10 {commands can be imported from many namespaces} { namespace import test_ns_import2::* lsort [concat [info commands cmd*] [info commands ncmd*]] } {cmd1 cmd2 ncmd ncmd1 ncmd2} +namespace eval test_ns_import2 { + namespace export ncmd ncmd1 ncmd2 + proc ncmd {args} {return "ncmd: $args"} + proc ncmd1 {args} {return "ncmd1: $args"} + proc ncmd2 {args} {return "ncmd2: $args"} + proc ncmd3 {args} {return "ncmd3: $args"} +} +namespace import test_ns_import2::* test namespace-old-9.11 {imported commands can be removed by deleting them} { rename cmd1 "" lsort [concat [info commands cmd*] [info commands ncmd*]] } {cmd2 ncmd ncmd1 ncmd2} +catch { rename cmd1 "" } test namespace-old-9.12 {command "namespace forget" checks for valid namespaces} { list [catch {namespace forget xyzzy::*} msg] $msg } {1 {unknown namespace in namespace forget pattern "xyzzy::*"}} @@ -653,6 +755,7 @@ test namespace-old-9.15 {existing commands can't be overwritten} { [cmd1 3 5] } {1 {can't import command "cmd1": already exists} 8} test namespace-old-9.16 {use "-force" option to override existing commands} { + proc cmd1 {x y} { return [expr $x+$y] } list [cmd1 3 5] \ [namespace import -force test_ns_import::cmd?] \ [cmd1 3 5] @@ -711,10 +814,18 @@ test namespace-old-10.6 {with many args, each "scope" adds new args} { set sval [namespace eval test_ns_inscope {namespace code {one two}}] namespace code "$sval three" } {::namespace inscope ::test_ns_inscope {one two} three} +namespace eval test_ns_inscope { + proc show {args} { + return "show: $args" + } +} test namespace-old-10.7 {scoped commands work with eval} { set cref [namespace eval test_ns_inscope {namespace code show}] list [eval $cref "a" "b c" "d e f"] } {{show: a b c d e f}} +namespace eval test_ns_inscope { + variable x "x-value" +} test namespace-old-10.8 {scoped commands execute in namespace context} { set cref [namespace eval test_ns_inscope { namespace code {set x "some new value"} diff --git a/tests/namespace.test b/tests/namespace.test index cded1f4..f6f817b 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} @@ -82,12 +82,14 @@ test namespace-4.2 {Tcl_PushCallFrame with isProcCallFrame=0} { test namespace-5.1 {Tcl_PopCallFrame, no vars} { namespace eval test_ns_1::blodge {} ;# pushes then pops frame } {} -test namespace-5.2 {Tcl_PopCallFrame, local vars must be deleted} { +test namespace-5.2 {Tcl_PopCallFrame, local vars must be deleted} -setup { + namespace eval test_ns_1 {} +} -body { proc test_ns_1::r {} { set a 123 } test_ns_1::r ;# pushes then pop's r's frame -} {123} +} -result {123} test namespace-6.1 {Tcl_CreateNamespace} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -106,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_*]} @@ -194,7 +196,6 @@ test namespace-7.7 {Bug 1655305} -setup { interp delete slave } -result {} - test namespace-8.1 {TclTeardownNamespace, delete global namespace} { catch {interp delete test_interp} interp create test_interp @@ -264,7 +265,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 @@ -303,15 +304,24 @@ test namespace-9.4 {Tcl_Import, simple import} { } test_ns_import::p } {cmd1: 123} -test namespace-9.5 {Tcl_Import, RFE 1230597} { +test namespace-9.5 {Tcl_Import, RFE 1230597} -setup { + namespace eval test_ns_import {} + namespace eval test_ns_export {} +} -body { list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg -} {0 {}} -test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} { +} -result {0 {}} +test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} -setup { + namespace eval test_ns_import {} + namespace eval ::test_ns_export { + proc cmd1 {args} {return "cmd1: $args"} + namespace export cmd1 + } +} -body { namespace eval test_ns_import { namespace import -force ::test_ns_export::* cmd1 555 } -} {cmd1: 555} +} -result {cmd1: 555} test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} { catch {namespace delete {*}[namespace children :: test_ns_*]} namespace eval test_ns_export { @@ -329,7 +339,6 @@ test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} { [test_ns_import::cmd1 g h i] \ [test_ns_export::cmd1 j k l] } {{cmd1: a b c} {cmd1: d e f} {} ::test_ns_export::cmd1 ::test_ns_export::cmd1 {new1: g h i} {new1: j k l}} - test namespace-9.8 {Tcl_Import: Bug 1017299} -setup { namespace eval one { namespace export cmd @@ -354,7 +363,6 @@ test namespace-9.8 {Tcl_Import: Bug 1017299} -setup { } -cleanup { namespace delete one two three } -match glob -result *::one::cmd - test namespace-9.9 {Tcl_Import: Bug 1017299} -setup { namespace eval one { namespace export cmd @@ -388,7 +396,13 @@ test namespace-10.2 {Tcl_ForgetImport, ignores patterns that don't match} { namespace forget ::test_ns_export::wombat } } {} -test namespace-10.3 {Tcl_ForgetImport, deletes matching imported cmds} { +test namespace-10.3 {Tcl_ForgetImport, deletes matching imported cmds} -setup { + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } +} -body { namespace eval test_ns_import { namespace import ::test_ns_export::* proc p {} {return [cmd1 123]} @@ -398,8 +412,7 @@ test namespace-10.3 {Tcl_ForgetImport, deletes matching imported cmds} { lappend l [info commands ::test_ns_import::*] lappend l [catch {cmd1 777} msg] $msg } -} [list [lsort {::test_ns_import::p ::test_ns_import::cmd1}] ::test_ns_import::p 1 {invalid command name "cmd1"}] - +} -result [list [lsort {::test_ns_import::p ::test_ns_import::cmd1}] ::test_ns_import::p 1 {invalid command name "cmd1"}] test namespace-10.4 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -417,7 +430,6 @@ test namespace-10.4 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin unrelated my } - test namespace-10.5 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -433,7 +445,6 @@ test namespace-10.5 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin my } -returnCodes error -match glob -result * - test namespace-10.6 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -450,7 +461,6 @@ test namespace-10.6 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin my your } -returnCodes error -match glob -result * - test namespace-10.7 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -471,7 +481,6 @@ test namespace-10.7 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin link link2 my } -returnCodes error -match glob -result * - test namespace-10.8 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -492,7 +501,6 @@ test namespace-10.8 {Tcl_ForgetImport: Bug 560297} -setup { } -cleanup { namespace delete origin link link2 my } - test namespace-10.9 {Tcl_ForgetImport: Bug 560297} -setup { namespace eval origin { namespace export cmd @@ -514,29 +522,47 @@ test namespace-10.9 {Tcl_ForgetImport: Bug 560297} -setup { namespace delete origin link link2 my } -returnCodes error -match glob -result * -test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} { +test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_export { namespace export cmd1 proc cmd1 {args} {return "cmd1: $args"} } list [namespace origin set] [namespace origin test_ns_export::cmd1] -} {::set ::test_ns_export::cmd1} -test namespace-11.2 {TclGetOriginalCommand, directly imported cmd} { +} -result {::set ::test_ns_export::cmd1} +test namespace-11.2 {TclGetOriginalCommand, directly imported cmd} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + } +} -body { namespace eval test_ns_import1 { namespace import ::test_ns_export::* namespace export * proc p {} {namespace origin cmd1} } list [test_ns_import1::p] [namespace origin test_ns_import1::cmd1] -} {::test_ns_export::cmd1 ::test_ns_export::cmd1} -test namespace-11.3 {TclGetOriginalCommand, indirectly imported cmd} { +} -result {::test_ns_export::cmd1 ::test_ns_export::cmd1} +test namespace-11.3 {TclGetOriginalCommand, indirectly imported cmd} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {return "cmd1: $args"} + } + namespace eval test_ns_import1 { + namespace import ::test_ns_export::* + namespace export * + proc p {} {namespace origin cmd1} + } +} -body { namespace eval test_ns_import2 { namespace import ::test_ns_import1::* proc q {} {return [cmd1 123]} } list [test_ns_import2::q] [namespace origin test_ns_import2::cmd1] -} {{cmd1: 123} ::test_ns_export::cmd1} +} -result {{cmd1: 123} ::test_ns_export::cmd1} test namespace-12.1 {InvokeImportedCmd} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -550,14 +576,23 @@ test namespace-12.1 {InvokeImportedCmd} { list [test_ns_import::cmd1] } {::test_ns_export} -test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} { +test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_export { + namespace export cmd1 + proc cmd1 {args} {namespace current} + } + namespace eval test_ns_import { + namespace import ::test_ns_export::* + } +} -body { namespace eval test_ns_import { set l {} lappend l [info commands ::test_ns_import::*] namespace forget ::test_ns_export::cmd1 lappend l [info commands ::test_ns_import::*] } -} {::test_ns_import::cmd1 {}} +} -result {::test_ns_import::cmd1 {}} test namespace-13.2 {DeleteImportedCmd, Bug a4494e28ed} { # Will panic if still buggy namespace eval src {namespace export foo; proc foo {} {}} @@ -568,7 +603,7 @@ test namespace-13.2 {DeleteImportedCmd, Bug a4494e28ed} { namespace delete src } {} -test namespace-14.1 {TclGetNamespaceForQualName, absolute names} { +test namespace-14.1 {TclGetNamespaceForQualName, absolute names} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} variable v 10 namespace eval test_ns_1::test_ns_2 { @@ -577,22 +612,41 @@ test namespace-14.1 {TclGetNamespaceForQualName, absolute names} { namespace eval test_ns_2 { variable v 30 } +} -body { namespace eval test_ns_1 { list $::v $::test_ns_2::v $::test_ns_1::test_ns_2::v \ [lsort [namespace children :: test_ns_*]] } -} [list 10 30 20 [lsort {::test_ns_1 ::test_ns_2}]] -test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} { +} -result [list 10 30 20 [lsort {::test_ns_1 ::test_ns_2}]] +test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + variable v 10 + namespace eval test_ns_1::test_ns_2 { + variable v 20 + } + namespace eval test_ns_2 { + variable v 30 + } +} -body { namespace eval test_ns_1 { list [catch {set ::test_ns_777::v} msg] $msg \ [catch {namespace children test_ns_777} msg] $msg } -} {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}} -test namespace-14.3 {TclGetNamespaceForQualName, relative names} { +} -result {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}} +test namespace-14.3 {TclGetNamespaceForQualName, relative names} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + variable v 10 + namespace eval test_ns_1::test_ns_2 { + variable v 20 + } + namespace eval test_ns_2 { + variable v 30 + } +} -body { namespace eval test_ns_1 { list $v $test_ns_2::v } -} {10 20} +} -result {10 20} test namespace-14.4 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} { namespace eval test_ns_1::test_ns_2 { namespace eval foo {} @@ -619,57 +673,72 @@ test namespace-14.6 {TclGetNamespaceForQualName, relative ns names looked up onl [catch {namespace children test_ns_1} msg] $msg } } {::test_ns_1::test_ns_2::foo 1 {namespace "test_ns_1" not found in "::test_ns_1"}} -test namespace-14.7 {TclGetNamespaceForQualName, ignore extra :s if ns} { +test namespace-14.7 {TclGetNamespaceForQualName, ignore extra :s if ns} -setup { + namespace eval test_ns_1::test_ns_2::foo {} +} -body { namespace children test_ns_1::: -} {::test_ns_1::test_ns_2} -test namespace-14.8 {TclGetNamespaceForQualName, ignore extra :s if ns} { +} -result {::test_ns_1::test_ns_2} +test namespace-14.8 {TclGetNamespaceForQualName, ignore extra :s if ns} -setup { + namespace eval test_ns_1::test_ns_2::foo {} +} -body { namespace children :::test_ns_1:::::test_ns_2::: -} {::test_ns_1::test_ns_2::foo} +} -result {::test_ns_1::test_ns_2::foo} test namespace-14.9 {TclGetNamespaceForQualName, extra ::s are significant for vars} { set l {} lappend l [catch {set test_ns_1::test_ns_2::} msg] $msg namespace eval test_ns_1::test_ns_2 {variable {} 2525} lappend l [set test_ns_1::test_ns_2::] } {1 {can't read "test_ns_1::test_ns_2::": no such variable} 2525} -test namespace-14.10 {TclGetNamespaceForQualName, extra ::s are significant for vars} { - catch {unset test_ns_1::test_ns_2::} +test namespace-14.10 {TclGetNamespaceForQualName, extra ::s are significant for vars} -setup { + namespace eval test_ns_1::test_ns_2::foo {} + unset -nocomplain test_ns_1::test_ns_2:: set l {} +} -body { lappend l [catch {set test_ns_1::test_ns_2::} msg] $msg set test_ns_1::test_ns_2:: 314159 lappend l [set test_ns_1::test_ns_2::] -} {1 {can't read "test_ns_1::test_ns_2::": no such variable} 314159} -test namespace-14.11 {TclGetNamespaceForQualName, extra ::s are significant for commands} { +} -result {1 {can't read "test_ns_1::test_ns_2::": no such variable} 314159} +test namespace-14.11 {TclGetNamespaceForQualName, extra ::s are significant for commands} -setup { + namespace eval test_ns_1::test_ns_2::foo {} catch {rename test_ns_1::test_ns_2:: {}} set l {} +} -body { lappend l [catch {test_ns_1::test_ns_2:: hello} msg] $msg proc test_ns_1::test_ns_2:: {args} {return "\{\}: $args"} lappend l [test_ns_1::test_ns_2:: hello] -} {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}} -test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} { +} -result {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}} +test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { variable {} set test_ns_1::(x) y } set test_ns_1::(x) -} y -test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} { +} -result y +test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} - list [catch {namespace eval test_ns_1 {proc {} {} {}; namespace eval {} {}; {}}} msg] $msg -} {1 {can't create namespace "": only global namespace can have empty name}} +} -returnCodes error -body { + namespace eval test_ns_1 { + proc {} {} {} + namespace eval {} {} + {} + } +} -result {can't create namespace "": only global namespace can have empty name} -test namespace-15.1 {Tcl_FindNamespace, absolute name found} { +test namespace-15.1 {Tcl_FindNamespace, absolute name found} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_delete { namespace eval test_ns_delete2 {} proc cmd {args} {namespace current} } list [namespace delete ::test_ns_delete::test_ns_delete2] \ [namespace children ::test_ns_delete] -} {{} {}} -test namespace-15.2 {Tcl_FindNamespace, absolute name not found} { - list [catch {namespace delete ::test_ns_delete::test_ns_delete2} msg] $msg -} {1 {unknown namespace "::test_ns_delete::test_ns_delete2" in namespace delete command}} +} -result {{} {}} +test namespace-15.2 {Tcl_FindNamespace, absolute name not found} -body { + namespace delete ::test_ns_delete::test_ns_delete2 +} -returnCodes error -result {unknown namespace "::test_ns_delete::test_ns_delete2" in namespace delete command} test namespace-15.3 {Tcl_FindNamespace, relative name found} { namespace eval test_ns_delete { namespace eval test_ns_delete2 {} @@ -685,17 +754,24 @@ test namespace-15.4 {Tcl_FindNamespace, relative name not found} { } } {1 {unknown namespace "test_ns_delete2" in namespace delete command}} -test namespace-16.1 {Tcl_FindCommand, absolute name found} { +test namespace-16.1 {Tcl_FindCommand, absolute name found} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { proc cmd {args} {return "[namespace current]::cmd: $args"} variable v "::test_ns_1::cmd" eval $v one } -} {::test_ns_1::cmd: one} -test namespace-16.2 {Tcl_FindCommand, absolute name found} { +} -result {::test_ns_1::cmd: one} +test namespace-16.2 {Tcl_FindCommand, absolute name found} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1 { + proc cmd {args} {return "[namespace current]::cmd: $args"} + variable v "::test_ns_1::cmd" + } +} -body { eval $test_ns_1::v two -} {::test_ns_1::cmd: two} +} -result {::test_ns_1::cmd: two} test namespace-16.3 {Tcl_FindCommand, absolute name not found} { namespace eval test_ns_1 { variable v2 "::test_ns_1::ladidah" @@ -724,11 +800,16 @@ test namespace-16.7 {Tcl_FindCommand, relative name and TCL_GLOBAL_ONLY} { catch {rename unknown {}} catch {rename unknown.old unknown} -test namespace-16.8 {Tcl_FindCommand, relative name found} { +test namespace-16.8 {Tcl_FindCommand, relative name found} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1 { + proc cmd {args} {return "[namespace current]::cmd: $args"} + } +} -body { namespace eval test_ns_1 { cmd a b c } -} {::test_ns_1::cmd: a b c} +} -result {::test_ns_1::cmd: a b c} test namespace-16.9 {Tcl_FindCommand, relative name found} -body { proc cmd2 {args} {return "[namespace current]::cmd2: $args"} namespace eval test_ns_1 { @@ -750,20 +831,22 @@ test namespace-16.10 {Tcl_FindCommand, relative name found, only look in current } -cleanup { catch {rename cmd2 {}} } -result {::::cmd2: a b c} -test namespace-16.11 {Tcl_FindCommand, relative name not found} { +test namespace-16.11 {Tcl_FindCommand, relative name not found} -body { namespace eval test_ns_1 { - list [catch {cmd3 a b c} msg] $msg + cmd3 a b c } -} {1 {invalid command name "cmd3"}} +} -returnCodes error -result {invalid command name "cmd3"} -catch {unset x} -test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} { +unset -nocomplain x +test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { set x 314159 namespace eval test_ns_1 { set ::x } -} {314159} +} -result {314159} +variable ::x 314159 test namespace-17.2 {Tcl_FindNamespaceVar, absolute name found} { namespace eval test_ns_1 { variable x 777 @@ -778,46 +861,54 @@ test namespace-17.3 {Tcl_FindNamespaceVar, absolute name found} { set ::test_ns_1::test_ns_2::x } } {1111} -test namespace-17.4 {Tcl_FindNamespaceVar, absolute name not found} { +test namespace-17.4 {Tcl_FindNamespaceVar, absolute name not found} -body { namespace eval test_ns_1 { namespace eval test_ns_2 { variable x 1111 } - list [catch {set ::test_ns_1::test_ns_2::y} msg] $msg + set ::test_ns_1::test_ns_2::y } -} {1 {can't read "::test_ns_1::test_ns_2::y": no such variable}} -test namespace-17.5 {Tcl_FindNamespaceVar, absolute name and TCL_GLOBAL_ONLY} { +} -returnCodes error -result {can't read "::test_ns_1::test_ns_2::y": no such variable} +test namespace-17.5 {Tcl_FindNamespaceVar, absolute name and TCL_GLOBAL_ONLY} -setup { + namespace eval ::test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1 { namespace eval test_ns_3 { variable ::test_ns_1::test_ns_2::x 2222 } } set ::test_ns_1::test_ns_2::x -} {2222} -test namespace-17.6 {Tcl_FindNamespaceVar, relative name found} { +} -result {2222} +test namespace-17.6 {Tcl_FindNamespaceVar, relative name found} -setup { + namespace eval test_ns_1 { + variable x 777 + } +} -body { namespace eval test_ns_1 { set x } -} {777} +} -result {777} test namespace-17.7 {Tcl_FindNamespaceVar, relative name found} { namespace eval test_ns_1 { + variable x 777 unset x set x ;# must be global x now } } {314159} -test namespace-17.8 {Tcl_FindNamespaceVar, relative name not found} { +test namespace-17.8 {Tcl_FindNamespaceVar, relative name not found} -body { namespace eval test_ns_1 { - list [catch {set wuzzat} msg] $msg + set wuzzat } -} {1 {can't read "wuzzat": no such variable}} +} -returnCodes error -result {can't read "wuzzat": no such variable} test namespace-17.9 {Tcl_FindNamespaceVar, relative name and TCL_GLOBAL_ONLY} { namespace eval test_ns_1 { variable a hello } set test_ns_1::a } {hello} -test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} { +test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} -setup { namespace eval test_ns_1 {} +} -body { proc test_ns {} { set ::test_ns_1::a 0 } @@ -828,14 +919,15 @@ test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} { namespace eval test_ns_1 set a 1 namespace delete test_ns_1 return $a -} 1 +} -result 1 catch {unset a} catch {unset x} catch {unset l} catch {rename foo {}} -test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} { +test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { proc foo {} {return "global foo"} namespace eval test_ns_1 { proc trigger {} { @@ -849,7 +941,7 @@ test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadow proc foo {} {return "foo in test_ns_1"} } lappend l [test_ns_1::trigger] -} {{global foo} {foo in test_ns_1}} +} -result {{global foo} {foo in test_ns_1}} test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shadowing} { namespace eval test_ns_2 { proc foo {} {return "foo in ::test_ns_2"} @@ -873,22 +965,31 @@ test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shado catch {unset l} catch {rename foo {}} -test namespace-19.1 {GetNamespaceFromObj, global name found} { +test namespace-19.1 {GetNamespaceFromObj, global name found} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1::test_ns_2 {} namespace children ::test_ns_1 -} {::test_ns_1::test_ns_2} -test namespace-19.2 {GetNamespaceFromObj, relative name found} { +} -result {::test_ns_1::test_ns_2} +test namespace-19.2 {GetNamespaceFromObj, relative name found} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1 { namespace children test_ns_2 } -} {} -test namespace-19.3 {GetNamespaceFromObj, name not found} -body { +} -result {} +test namespace-19.3 {GetNamespaceFromObj, name not found} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { namespace children test_ns_99 } } -returnCodes error -result {namespace "test_ns_99" not found in "::test_ns_1"} -test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} { +test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1 { proc foo {} { return [namespace children test_ns_2] @@ -900,7 +1001,7 @@ test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} { namespace delete test_ns_1::test_ns_2 namespace eval test_ns_1::test_ns_2::test_ns_3 {} lappend l [test_ns_1::foo] -} {{} ::test_ns_1::test_ns_2::test_ns_3} +} -result {{} ::test_ns_1::test_ns_2::test_ns_3} test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -913,24 +1014,34 @@ test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} { namespace ch :: test_ns_* } {} -test namespace-21.1 {NamespaceChildrenCmd, no args} { +test namespace-21.1 {NamespaceChildrenCmd, no args} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { + namespace eval test_ns_1::test_ns_2 {} + expr {"::test_ns_1" in [namespace children]} +} -result {1} +test namespace-21.2 {NamespaceChildrenCmd, no args} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} namespace eval test_ns_1::test_ns_2 {} - expr {[string first ::test_ns_1 [namespace children]] != -1} -} {1} -test namespace-21.2 {NamespaceChildrenCmd, no args} { +} -body { namespace eval test_ns_1 { namespace children } -} {::test_ns_1::test_ns_2} -test namespace-21.3 {NamespaceChildrenCmd, ns name given} { +} -result {::test_ns_1::test_ns_2} +test namespace-21.3 {NamespaceChildrenCmd, ns name given} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace children ::test_ns_1 -} {::test_ns_1::test_ns_2} -test namespace-21.4 {NamespaceChildrenCmd, ns name given} { +} -result {::test_ns_1::test_ns_2} +test namespace-21.4 {NamespaceChildrenCmd, ns name given} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1 { namespace children test_ns_2 } -} {} +} -result {} test namespace-21.5 {NamespaceChildrenCmd, too many args} { namespace eval test_ns_1 { list [catch {namespace children test_ns_2 xxx yyy} msg] $msg @@ -940,10 +1051,13 @@ test namespace-21.6 {NamespaceChildrenCmd, glob-style pattern given} { namespace eval test_ns_1::test_ns_foo {} namespace children test_ns_1 *f* } {::test_ns_1::test_ns_foo} -test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} { +test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} -setup { + catch {namespace delete {*}[namespace children :: test_ns_*]} + namespace eval test_ns_1::test_ns_2 {} +} -body { namespace eval test_ns_1::test_ns_foo {} lsort [namespace children test_ns_1 test*] -} [lsort {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_foo}] +} -result {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_foo} test namespace-21.8 {NamespaceChildrenCmd, trivial pattern starting with ::} { namespace eval test_ns_1 {} namespace children [namespace current] [fq test_ns_1] @@ -971,17 +1085,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} @@ -1038,15 +1152,25 @@ test namespace-25.3 {NamespaceEvalCmd, new namespace} { } test_ns_1::p } {314159} -test namespace-25.4 {NamespaceEvalCmd, existing namespace} { +test namespace-25.4 {NamespaceEvalCmd, existing namespace} -setup { + namespace eval test_ns_1 { + variable v 314159 + proc p {} { + variable v + return $v + } + } +} -body { namespace eval test_ns_1 { proc q {} {return [expr {[p]+1}]} } test_ns_1::q -} {314160} -test namespace-25.5 {NamespaceEvalCmd, multiple args} { +} -result {314160} +test namespace-25.5 {NamespaceEvalCmd, multiple args} -setup { + namespace eval test_ns_1 {variable v 314159} +} -body { namespace eval test_ns_1 "set" "v" -} {314159} +} -result {314159} test namespace-25.6 {NamespaceEvalCmd, error in eval'd script} { list [catch {namespace eval test_ns_1 {xxxx}} msg] $msg $::errorInfo } {1 {invalid command name "xxxx"} {invalid command name "xxxx" @@ -1097,21 +1221,50 @@ test namespace-26.4 {NamespaceExportCmd, one pattern} { } list [info commands test_ns_2::*] [test_ns_2::cmd1 hello] } {::test_ns_2::cmd1 {cmd1: hello}} -test namespace-26.5 {NamespaceExportCmd, sequence of patterns, patterns accumulate} { +test namespace-26.5 {NamespaceExportCmd, sequence of patterns, patterns accumulate} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} namespace eval test_ns_1 { + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} namespace export cmd1 cmd3 } +} -body { namespace eval test_ns_2 { namespace import -force ::test_ns_1::* } list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd3 hello] -} [list [lsort {::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd3: hello}] -test namespace-26.6 {NamespaceExportCmd, no patterns means return uniq'ed export list} { +} -result {{::test_ns_2::cmd1 ::test_ns_2::cmd3} {cmd3: hello}} +test namespace-26.6 {NamespaceExportCmd, no patterns means return uniq'ed export list} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} + namespace eval test_ns_1 { + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} + namespace export cmd1 cmd3 + } +} -body { namespace eval test_ns_1 { namespace export } -} {cmd1 cmd3} -test namespace-26.7 {NamespaceExportCmd, -clear resets export list} { +} -result {cmd1 cmd3} +test namespace-26.7 {NamespaceExportCmd, -clear resets export list} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} + namespace eval test_ns_1 { + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + proc cmd3 {args} {return "cmd3: $args"} + proc cmd4 {args} {return "cmd4: $args"} + } +} -body { + namespace eval test_ns_1 { + namespace export cmd1 cmd3 + } + namespace eval test_ns_2 { + namespace import ::test_ns_1::* + } namespace eval test_ns_1 { namespace export -clear cmd4 } @@ -1119,7 +1272,7 @@ test namespace-26.7 {NamespaceExportCmd, -clear resets export list} { namespace import ::test_ns_1::* } list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd4 hello] -} [list [lsort {::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd4: hello}] +} -result [list [lsort {::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd4: hello}] test namespace-26.8 {NamespaceExportCmd, -clear resets export list} { catch {namespace delete foo} namespace eval foo { @@ -1202,14 +1355,23 @@ test namespace-29.4 {NamespaceInscopeCmd, simple case} { } namespace inscope test_ns_1 cmd } {::test_ns_1::cmd: v=747, args=} -test namespace-29.5 {NamespaceInscopeCmd, has lappend semantics} { +test namespace-29.5 {NamespaceInscopeCmd, has lappend semantics} -setup { + namespace eval test_ns_1 { + variable v 747 + proc cmd {args} { + variable v + return "[namespace current]::cmd: v=$v, args=$args" + } + } +} -body { list [namespace inscope test_ns_1 cmd x y z] \ [namespace eval test_ns_1 [concat cmd [list x y z]]] -} {{::test_ns_1::cmd: v=747, args=x y z} {::test_ns_1::cmd: v=747, args=x y z}} -test namespace-29.6 {NamespaceInscopeCmd, 1400572} { +} -result {{::test_ns_1::cmd: v=747, args=x y z} {::test_ns_1::cmd: v=747, args=x y z}} +test namespace-29.6 {NamespaceInscopeCmd, 1400572} -setup { + namespace eval test_ns_1 {} +} -body { namespace inscope test_ns_1 {info level 0} -} {namespace inscope test_ns_1 {info level 0}} - +} -result {namespace inscope test_ns_1 {info level 0}} test namespace-30.1 {NamespaceOriginCmd, bad args} { catch {namespace delete {*}[namespace children :: test_ns_*]} @@ -1330,7 +1492,8 @@ test namespace-34.3 {NamespaceWhichCmd, single arg is always command name} { test namespace-34.4 {NamespaceWhichCmd, bad args} { list [catch {namespace which a b} msg] $msg } {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}} -test namespace-34.5 {NamespaceWhichCmd, command lookup} { +test namespace-34.5 {NamespaceWhichCmd, command lookup} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} namespace eval test_ns_1 { namespace export cmd* variable v1 111 @@ -1343,6 +1506,7 @@ test namespace-34.5 {NamespaceWhichCmd, command lookup} { variable v2 222 proc p {} {} } +} -body { namespace eval test_ns_3 { namespace import ::test_ns_2::* variable v3 333 @@ -1352,26 +1516,59 @@ test namespace-34.5 {NamespaceWhichCmd, command lookup} { [namespace which -command ::test_ns_2::cmd2] \ [catch {namespace which -command ::test_ns_2::noSuchCmd} msg] $msg } -} {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2 0 {}} -test namespace-34.6 {NamespaceWhichCmd, -command is default} { +} -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2 0 {}} +test namespace-34.6 {NamespaceWhichCmd, -command is default} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} + namespace eval test_ns_1 { + namespace export cmd* + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_2 { + namespace export * + namespace import ::test_ns_1::* + proc p {} {} + } + namespace eval test_ns_3 { + namespace import ::test_ns_2::* + } +} -body { namespace eval test_ns_3 { list [namespace which foreach] \ [namespace which p] \ [namespace which cmd1] \ [namespace which ::test_ns_2::cmd2] } -} {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2} -test namespace-34.7 {NamespaceWhichCmd, variable lookup} { +} -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2} +test namespace-34.7 {NamespaceWhichCmd, variable lookup} -setup { + catch {namespace delete {*}[namespace children test_ns_*]} + namespace eval test_ns_1 { + namespace export cmd* + proc cmd1 {args} {return "cmd1: $args"} + proc cmd2 {args} {return "cmd2: $args"} + } + namespace eval test_ns_2 { + namespace export * + namespace import ::test_ns_1::* + variable v2 222 + proc p {} {} + } + namespace eval test_ns_3 { + variable v3 333 + namespace import ::test_ns_2::* + } +} -body { namespace eval test_ns_3 { list [namespace which -variable env] \ [namespace which -variable v3] \ [namespace which -variable ::test_ns_2::v2] \ [catch {namespace which -variable ::test_ns_2::noSuchVar} msg] $msg } -} {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}} +} -result {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}} -test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} { +test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} +} -body { namespace eval test_ns_1 { proc p {} { namespace delete [namespace current] @@ -1379,7 +1576,7 @@ test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} { } } test_ns_1::p -} {::test_ns_1} +} -result {::test_ns_1} test namespace-35.2 {FreeNsNameInternalRep, resulting ref count == 0} { namespace eval test_ns_1 { proc q {} { @@ -1449,7 +1646,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} @@ -1460,7 +1657,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] @@ -2107,6 +2304,68 @@ test namespace-50.4 {chained ensembles affect error messages} -body { rename a {} rename c {} } +test namespace-50.5 {[4402cfa58c]} -setup { + proc bar {ev} {} + proc bingo {xx} {} + namespace ensemble create -command launch -map {foo bar event bingo} + set result {} +} -body { + catch {launch foo} m; lappend result $m + catch {launch ev} m; lappend result $m + catch {launch foo} m; lappend result $m +} -cleanup { + rename launch {} + rename bingo {} + rename bar {} +} -result {{wrong # args: should be "launch foo ev"} {wrong # args: should be "launch event xx"} {wrong # args: should be "launch foo ev"}} +test namespace-50.6 {[4402cfa58c]} -setup { + proc target {x y} {} + namespace ensemble create -command e2 -map {s2 target} + namespace ensemble create -command e1 -map {s1 e2} + set result {} +} -body { + set s s + catch {e1 s1 s2 a} m; lappend result $m + catch {e1 $s s2 a} m; lappend result $m + catch {e1 s1 $s a} m; lappend result $m + catch {e1 $s $s a} m; lappend result $m +} -cleanup { + rename e1 {} + rename e2 {} + rename target {} +} -result {{wrong # args: should be "e1 s1 s2 x y"} {wrong # args: should be "e1 s1 s2 x y"} {wrong # args: should be "e1 s1 s2 x y"} {wrong # args: should be "e1 s1 s2 x y"}} +test namespace-50.7 {[4402cfa58c]} -setup { + proc target {x y} {} + namespace ensemble create -command e2 -map {s2 target} + namespace ensemble create -command e1 -map {s1 e2} -parameters foo + set result {} +} -body { + set s s + catch {e1 s2 s1 a} m; lappend result $m + catch {e1 $s s1 a} m; lappend result $m + catch {e1 s2 $s a} m; lappend result $m + catch {e1 $s $s a} m; lappend result $m +} -cleanup { + rename e1 {} + rename e2 {} + rename target {} +} -result {{wrong # args: should be "e1 s2 s1 x y"} {wrong # args: should be "e1 s2 s1 x y"} {wrong # args: should be "e1 s2 s1 x y"} {wrong # args: should be "e1 s2 s1 x y"}} +test namespace-50.8 {[f961d7d1dd]} -setup { + proc target {} {} + namespace ensemble create -command e -map {s target} -parameters {{a b}} +} -body { + e +} -returnCodes error -result {wrong # args: should be "e {a b} subcommand ?arg ...?"} -cleanup { + rename e {} + rename target {} +} +test namespace-50.9 {[cea0344a51]} -body { + namespace eval foo { + namespace eval bar { + namespace delete foo + } + } +} -returnCodes error -result {unknown namespace "foo" in namespace delete command} test namespace-51.1 {name resolution path control} -body { namespace eval ::test_ns_1 { @@ -2928,6 +3187,22 @@ test namespace-53.10 {ensembles: nested rewrite} -setup { 0 {1 v}\ 1 {wrong # args: should be "ns v x z2 a2"}\ 0 {2 v v2}} +test namespace-53.11 {ensembles: nested rewrite} -setup { + namespace eval ns { + namespace export x + namespace eval x { + proc z2 {a1 a2} {list 2 $a1 $a2} + namespace export z* + namespace ensemble create -parameter p + } + namespace ensemble create + } +} -body { + list [catch {ns x 1 z2} msg] $msg +} -cleanup { + namespace delete ns + unset -nocomplain msg +} -result {1 {wrong # args: should be "ns x 1 z2 a2"}} test namespace-54.1 {leak on namespace deletion} -constraints {memory} \ -setup { @@ -2953,6 +3228,45 @@ test namespace-54.1 {leak on namespace deletion} -constraints {memory} \ test namespace-55.1 {compiled ensembles inside compiled ensembles: Bug 6d2f249a01} { info class [format %s constructor] oo::object } "" + +test namespace-56.1 {bug f97d4ee020: mutually-entangled deletion} { + namespace eval ::testing { + proc abc {} {} + proc def {} {} + trace add command abc delete "rename ::testing::def {}; #" + trace add command def delete "rename ::testing::abc {}; #" + } + namespace delete ::testing +} {} +test namespace-56.2 {bug f97d4ee020: mutually-entangled deletion} { + namespace eval ::testing { + namespace eval abc {proc xyz {} {}} + namespace eval def {proc xyz {} {}} + trace add command abc::xyz delete "namespace delete ::testing::def {}; #" + trace add command def::xyz delete "namespace delete ::testing::abc {}; #" + } + namespace delete ::testing +} {} +test namespace-56.3 {bug f97d4ee020: mutually-entangled deletion} { + namespace eval ::testing { + variable gone {} + oo::class create CB { + variable cmd + constructor other {set cmd $other} + destructor {rename $cmd {}; lappend ::testing::gone $cmd} + } + namespace eval abc { + ::testing::CB create def ::testing::abc::ghi + ::testing::CB create ghi ::testing::abc::def + } + namespace delete abc + try { + return [lsort $gone] + } finally { + namespace delete ::testing + } + } +} {::testing::abc::def ::testing::abc::ghi} # cleanup catch {rename cmd1 {}} diff --git a/tests/nre.test b/tests/nre.test index e512eac..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] @@ -64,6 +64,12 @@ if {[testConstraint testnrelevels]} { namespace import testnre::* } +test nre-0.1 {levels while unwinding} -body { + testnreunwind +} -constraints { + testnrelevels +} -result {0 0 0} + test nre-1.1 {self-recursive procs} -setup { proc a i [makebody {a $i}] } -body { @@ -323,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 151abfb..833c906 100644 --- a/tests/obj.test +++ b/tests/obj.test @@ -26,7 +26,6 @@ testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj { set r 1 foreach {t} { - {array search} bytearray bytecode cmdName @@ -82,7 +81,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 +90,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] @@ -626,6 +625,19 @@ test obj-33.7 {integer overflow on input} { list [string is integer $x] [expr { wide($x) }] } {0 -4294967296} +test obj-34.1 {mp_iseven} testobj { + set result "" + lappend result [testbignumobj set 1 0] + lappend result [testbignumobj iseven 1] ; + lappend result [testobj type 1] +} {0 1 int} +test obj-34.2 {mp_radix_size} testobj { + set result "" + lappend result [testbignumobj set 1 9] + lappend result [testbignumobj radixsize 1] ; + lappend result [testobj type 1] +} {9 2 int} + if {[testConstraint testobj]} { testobj freeallvars } diff --git a/tests/oo.test b/tests/oo.test index c83e015..e03911b 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -280,7 +280,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] @@ -638,6 +638,57 @@ test oo-3.9 {Bug 2944404: deleting the object in the destructor} -setup { } -cleanup { cls destroy } -result {in destructor} +test oo-3.10 {Bug 3d96b7076e: killing the object's class in a method call} -setup { + oo::class create Super +} -body { + # Only reliably failed in a memdebug build + oo::class create Cls { + superclass Super + method mthd {} { + [self class] destroy + return ok + } + } + [Cls new] mthd +} -cleanup { + Super destroy +} -result ok +test oo-3.11 {Bug 3d96b7076e: killing the object's class in a method call} -setup { + oo::class create Super + oo::class create Sub { + superclass Super + } +} -body { + # Only reliably failed in a memdebug build + oo::class create Cls { + superclass Super + method mthd {} { + oo::objdefine [self] class Sub + Cls destroy + return ok + } + } + [Cls new] mthd +} -cleanup { + Super destroy +} -result ok +test oo-3.12 {Bug 3d96b7076e: killing the object's class in a method call} -setup { + oo::class create Super +} -body { + # Only reliably failed in a memdebug build + oo::class create Cls { + superclass Super + method mthd {} { + [self class] destroy + return ok + } + } + set o [Super new] + oo::objdefine $o mixin Cls + $o mthd +} -cleanup { + Super destroy +} -result ok test oo-4.1 {basic test of OO functionality: export} { set o [oo::object new] @@ -1938,7 +1989,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 } @@ -1966,6 +2017,12 @@ test oo-15.10 {variable binding must not bleed through oo::copy} -setup { test oo-16.1 {OO: object introspection} -body { info object } -returnCodes 1 -result "wrong \# args: should be \"info object subcommand ?arg ...?\"" +test oo-16.1.1 {OO: object introspection} -body { + catch {info object} m o + dict get $o -errorinfo +} -result "wrong \# args: should be \"info object subcommand ?arg ...?\" + while executing +\"info object\"" test oo-16.2 {OO: object introspection} -body { info object class NOTANOBJECT } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} @@ -2105,6 +2162,12 @@ test oo-16.14 {OO: object introspection: TIP #436} -setup { test oo-17.1 {OO: class introspection} -body { info class } -returnCodes 1 -result "wrong \# args: should be \"info class subcommand ?arg ...?\"" +test oo-17.1.1 {OO: class introspection} -body { + catch {info class} m o + dict get $o -errorinfo +} -result "wrong \# args: should be \"info class subcommand ?arg ...?\" + while executing +\"info class\"" test oo-17.2 {OO: class introspection} -body { info class superclass NOTANOBJECT } -returnCodes 1 -result {NOTANOBJECT does not refer to an object} @@ -2178,6 +2241,44 @@ test oo-17.10 {OO: class introspection} -setup { oo::define foo unexport {*}[info class methods foo -all] info class methods foo -all } -result {} +set stdmethods {<cloned> destroy eval unknown variable varname} +test oo-17.11 {OO: object method unexport (bug 900cb0284bc)} -setup { + oo::object create o + oo::objdefine o unexport m +} -body { + lsort [info object methods o -all -private] +} -cleanup { + o destroy +} -result $stdmethods +test oo-17.12 {OO: instance method unexport (bug 900cb0284bc)} -setup { + oo::class create c + c create o + oo::objdefine o unexport m +} -body { + lsort [info object methods o -all -private] +} -cleanup { + o destroy + c destroy +} -result $stdmethods +test oo-17.13 {OO: class method unexport (bug 900cb0284bc)} -setup { + oo::class create c + oo::define c unexport m +} -body { + lsort [info class methods c -all -private] +} -cleanup { + c destroy +} -result $stdmethods +test oo-17.14 {OO: instance method unexport (bug 900cb0284bc)} -setup { + oo::class create c + oo::define c unexport m + c create o +} -body { + lsort [info object methods o -all -private] +} -cleanup { + o destroy + c destroy +} -result $stdmethods + test oo-18.1 {OO: define command support} { list [catch {oo::define oo::object {error foo}} msg] $msg $errorInfo @@ -2568,7 +2669,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} { @@ -2583,7 +2684,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 } } @@ -3361,6 +3462,38 @@ test oo-27.22 {variables declaration uniqueifies: Bug 3396896} -setup { } -cleanup { foo destroy } -result {v t} +test oo-27.23 {variable resolver leakage: Bug 1493a43044} -setup { + oo::class create Super + oo::class create Master { + superclass Super + variable member1 member2 + constructor {} { + set member1 master1 + set member2 master2 + } + method getChild {} { + Child new [self] + } + } + oo::class create Child { + superclass Super + variable member1 result + constructor {m} { + set [namespace current]::member1 child1 + set ns [info object namespace $m] + namespace upvar $ns member1 l1 member2 l2 + upvar 1 member1 l3 member2 l4 + [format namespace] upvar $ns member1 l5 member2 l6 + [format upvar] 1 member1 l7 member2 l8 + set result [list $l1 $l2 $l3 $l4 $l5 $l6 $l7 $l8] + } + method result {} {return $result} + } +} -body { + [[Master new] getChild] result +} -cleanup { + Super destroy +} -result {master1 master2 master1 master2 master1 master2 master1 master2} # A feature that's not supported because the mechanism may change without # warning, but is supposed to work... @@ -3620,6 +3753,19 @@ test oo-35.2 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { unset -nocomplain result fruitMetaclass destroy } -result {::appleClass ::orange ::oo::class ::oo::class 1 1 ::appleClass ::pear} +test oo-35.3 {Bug 593baa032c: superclass list teardown} { + # Bug makes this crash, especially with mem-debugging on + oo::class create B {} + oo::class create D {superclass B} + namespace eval [info object namespace D] [list [namespace which B] destroy] +} {} +test oo-35.4 {Bug 593baa032c: mixins list teardown} { + # Bug makes this crash, especially with mem-debugging on + oo::class create B {} + oo::class create D {mixin B} + namespace eval [info object namespace D] [list [namespace which B] destroy] +} {} + cleanupTests return diff --git a/tests/package.test b/tests/package.test index da778f1..99f9f06 100644 --- a/tests/package.test +++ b/tests/package.test @@ -17,6 +17,11 @@ if {"::tcltest" ni [namespace children]} { namespace import -force ::tcltest::* } +::tcltest::loadTestedCommands +catch [list package require -exact Tcltest [info patchlevel]] + +testConstraint testpreferstable [llength [info commands testpreferstable]] + # Do all this in a slave interp to avoid garbaging the package list set i [interp create] tcltest::loadIntoSlaveInterpreter $i {*}$argv @@ -569,7 +574,8 @@ 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 { + testpreferstable package forget t set x xxx } -body { @@ -826,7 +832,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"} @@ -1233,9 +1239,11 @@ proc prefer {args} { } } -test package-13.0 {package prefer defaults} { +test package-13.0 {package prefer defaults} -constraints testpreferstable -setup { + testpreferstable +} -body { prefer -} stable +} -result stable test package-13.1 {package prefer defaults} -body { set ::env(TCL_PKG_PREFER_LATEST) stable ;# value not relevant! prefer @@ -1250,15 +1258,25 @@ 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} { +test package-15.0 {set, keep} -constraints testpreferstable -setup { + testpreferstable +} -body {package prefer stable} -result stable +test package-15.1 {set stable, keep} -constraints testpreferstable -setup { + testpreferstable +} -body {prefer stable} -result {stable stable} +test package-15.2 {set latest, change} -constraints testpreferstable -setup { + testpreferstable +} -body {prefer latest} -result {stable latest} +test package-15.3 {set latest, keep} -constraints testpreferstable -setup { + testpreferstable +} -body { prefer latest latest -} {stable latest latest} -test package-15.4 {set stable, rejected} { +} -result {stable latest latest} +test package-15.4 {set stable, rejected} -constraints testpreferstable -setup { + testpreferstable +} -body { prefer latest stable -} {stable latest latest} +} -result {stable latest 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/parseOld.test b/tests/parseOld.test index a6e07a2b..504d063 100644 --- a/tests/parseOld.test +++ b/tests/parseOld.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require tcltest +package require tcltest 2 namespace import ::tcltest::* ::tcltest::loadTestedCommands @@ -37,7 +37,7 @@ proc getArgs args { global argv set argv $args } - + # Basic argument parsing. test parseOld-1.1 {basic argument parsing} { @@ -296,6 +296,7 @@ test parseOld-8.4 {semi-colons} { # The following checks are to ensure that the interpreter's result # gets re-initialized by Tcl_Eval in all the right places. +set a 22 test parseOld-9.1 {result initialization} {concat abc} abc test parseOld-9.2 {result initialization} {concat abc; proc foo {} {}} {} test parseOld-9.3 {result initialization} {concat abc; proc foo {} $a} {} @@ -408,6 +409,8 @@ test parseOld-11.7 {long values} { set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH] llength $b } 43 +# Duplicate action of previous test +llength [set b [concat 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH]] test parseOld-11.8 {long values} { set b } $a @@ -538,8 +541,12 @@ test parseOld-15.4 {TclScriptEnd procedure} { test parseOld-15.5 {TclScriptEnd procedure} { info complete "xyz \[abc" } {0} - + # cleanup set argv $savedArgv ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: 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 6596975..5838a41 100644 --- a/tests/platform.test +++ b/tests/platform.test @@ -1,4 +1,4 @@ -# The file tests the tcl_platform variable +# The file tests the tcl_platform variable and platform package. # # 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 @@ -23,6 +23,10 @@ catch [list package require -exact Tcltest [info patchlevel]] testConstraint testCPUID [llength [info commands testcpuid]] +test platform-1.0 {tcl_platform(engine)} { + set tcl_platform(engine) +} {Tcl} + test platform-1.1 {TclpSetVariables: tcl_platform} { interp create i i eval {catch {unset tcl_platform(debug)}} @@ -30,7 +34,7 @@ test platform-1.1 {TclpSetVariables: tcl_platform} { set result [i eval {lsort [array names tcl_platform]}] interp delete i set result -} {byteOrder machine os osVersion pathSeparator platform pointerSize user wordSize} +} {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 @@ -47,16 +51,27 @@ test platform-2.1 {tcl_platform(wordSize) indicates size of native word} { 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)$} +# The platform package makes very few promises, but does promise that the +# 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 { + platform::identify +} -result {^([^-]+-)+[^-]+$} +test platform-4.2 {format of platform::generic result} -match regexp -body { + platform::generic +} -result {^([^-]+-)+[^-]+$} + # cleanup cleanupTests diff --git a/tests/proc.test b/tests/proc.test index e06720e..bae5e15 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,7 +107,7 @@ 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} @@ -329,7 +329,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} diff --git a/tests/reg.test b/tests/reg.test index 647bba8..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 @@ -1088,7 +1088,8 @@ test reg-33.13 {Bug 1810264 - infinite loop} { test reg-33.14 {Bug 1810264 - super-expensive expression} nonPortable { regexp {(x{200}){200}$y} {x} } 0 -test reg-33.15 {Bug 3603557 - an "in the wild" RE} { + +test reg-33.15.1 {Bug 3603557 - an "in the wild" RE} { lindex [regexp -expanded -about { ^TETRA_MODE_CMD # Message Type ([[:blank:]]+) # Pad @@ -1163,10 +1164,62 @@ test reg-33.15 {Bug 3603557 - an "in the wild" RE} { (.*) # ConditionalFields }] 0 } 68 -test reg-33.16 {Bug [8d2c0da36d]- another "in the wild" RE} { +test reg-33.16.1 {Bug [8d2c0da36d]- another "in the wild" RE} { lindex [regexp -about "^MRK:client1: =1339 14HKelly Talisman 10011000 (\[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]*) \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 8 0 8 0 0 0 77 77 1 1 2 0 11 { 1 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 13HC6 My Creator 2 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 31HC7 Slightly offensive name, huh 3 8 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 23HE-mail:kelly@hotbox.com 4 9 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 17Hcompface must die 5 10 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 3HAir 6 12 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 14HPGP public key 7 13 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 16Hkelly@hotbox.com 8 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 12H2 text/plain 9 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 13H2 x-kom/basic 10 33 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H0 11 14 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H3 }\r?"] 0 } 1 - + +test reg-33.15 {constraint fixes} { + regexp {(^)+^} x +} 1 +test reg-33.16 {constraint fixes} { + regexp {($^)+} x +} 0 +test reg-33.17 {constraint fixes} { + regexp {(^$)*} x +} 1 +test reg-33.18 {constraint fixes} { + regexp {(^(?!aa))+} {aa bb cc} +} 0 +test reg-33.19 {constraint fixes} { + regexp {(^(?!aa)(?!bb)(?!cc))+} {aa x} +} 0 +test reg-33.20 {constraint fixes} { + regexp {(^(?!aa)(?!bb)(?!cc))+} {bb x} +} 0 +test reg-33.21 {constraint fixes} { + regexp {(^(?!aa)(?!bb)(?!cc))+} {cc x} +} 0 +test reg-33.22 {constraint fixes} { + regexp {(^(?!aa)(?!bb)(?!cc))+} {dd x} +} 1 + +test reg-33.23 {} { + regexp {abcd(\m)+xyz} x +} 0 +test reg-33.24 {} { + regexp {abcd(\m)+xyz} a +} 0 +test reg-33.25 {} { + regexp {^abcd*(((((^(a c(e?d)a+|)+|)+|)+|)+|a)+|)} x +} 0 +test reg-33.26 {} { + regexp {a^(^)bcd*xy(((((($a+|)+|)+|)+$|)+|)+|)^$} x +} 0 +test reg-33.27 {} { + regexp {xyz(\Y\Y)+} x +} 0 +test reg-33.28 {} { + regexp {x|(?:\M)+} x +} 1 +test reg-33.29 {} { + # This is near the limits of the RE engine + regexp [string repeat x*y*z* 480] x +} 1 + +test reg-33.30 {Bug 1080042} { + regexp {(\Y)+} foo +} 1 + # cleanup ::tcltest::cleanupTests return diff --git a/tests/regexp.test b/tests/regexp.test index a83c99b..4ffdbdb 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -480,7 +480,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 +742,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} { @@ -864,7 +864,7 @@ test regexp-22.4 {Bug 3606139} -setup { [a 668]([a 55])[a 668]([a 55])[a 668]([a 55])[a 511]] {}] a } -cleanup { rename a {} -} -returnCodes 1 -result {couldn't compile regular expression pattern: nfa has too many states} +} -returnCodes 1 -match glob -result {couldn't compile regular expression pattern: *} test regexp-22.5 {Bug 3610026} -setup { set e {} set cp 99 diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 01ef06d..b8e64b6 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 @@ -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 0f78212..fec4cc0 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.1] + set ::regver [package require registry 1.3.2] }]} { 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.1} +} {1.3.2} 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/resolver.test b/tests/resolver.test index e73ea50..9bb4c08 100644 --- a/tests/resolver.test +++ b/tests/resolver.test @@ -135,6 +135,9 @@ test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -s z } } + namespace eval :: { + variable r2 "" + } } -constraints testinterpresolver -body { set r0 [namespace eval ::ns2 {x}] set r1 [namespace eval ::ns2 {z}] @@ -184,7 +187,7 @@ test resolver-2.1 {compiled var resolver: Bug #3383616} -setup { # During the compilation the compiled var resolver, the resolve-specific # var info is allocated, during the execution of the body, the variable is # fetched and cached. - x; + x # During later calls, the cached variable is reused. x # When the proc is freed, the resolver-specific resolver var info is @@ -193,6 +196,121 @@ test resolver-2.1 {compiled var resolver: Bug #3383616} -setup { } -cleanup { testinterpresolver down } -result {} + + +# +# The test resolver-3.1* test bad interactions of resolvers on the "global" +# (per interp) literal pools. A resolver might resolve a cmd literal depending +# on a context differently, whereas the cmd literal sharing assumed that the +# namespace containing the literal solely determines the resolved cmd (and is +# resolver-agnostic). +# +# In order to make the test cases for the per-interpreter cmd literal pool +# reproducable and to minimize interactions between test cases, we use a slave +# interpreter per test-case. +# +# +# Testing resolver in namespace-based context "ctx1" +# +test resolver-3.1a { + interp command resolver, + resolve literal "z" in proc "x1" in context "ctx1" +} -setup { + + interp create i0 + testinterpresolver up i0 + i0 eval { + proc y {} { return yy } + namespace eval ::ns { + proc x1 {} { z } + } + } +} -constraints testinterpresolver -body { + + set r [i0 eval {namespace eval ::ctx1 { + ::ns::x1 + }}] + + return $r +} -cleanup { + testinterpresolver down i0 + interp delete i0 +} -result {yy} + +# +# Testing resolver in namespace-based context "ctx2" +# +test resolver-3.1b { + interp command resolver, + resolve literal "z" in proc "x2" in context "ctx2" +} -setup { + + interp create i0 + testinterpresolver up i0 + i0 eval { + proc Y {} { return YY } + namespace eval ::ns { + proc x2 {} { z } + } + } +} -constraints testinterpresolver -body { + + set r [i0 eval {namespace eval ::ctx2 { + ::ns::x2 + }}] + + return $r +} -cleanup { + testinterpresolver down i0 + interp delete i0 +} -result {YY} + +# +# Testing resolver in namespace-based context "ctx1" and "ctx2" in the same +# interpreter. +# + +test resolver-3.1c { + interp command resolver, + resolve literal "z" in proc "x1" in context "ctx1", + resolve literal "z" in proc "x2" in context "ctx2" + + Test, whether the shared cmd literal created by the first byte-code + compilation interacts with the second one. +} -setup { + + interp create i0 + testinterpresolver up i0 + + i0 eval { + proc y {} { return yy } + proc Y {} { return YY } + namespace eval ::ns { + proc x1 {} { z } + proc x2 {} { z } + } + } + +} -constraints testinterpresolver -body { + + set r1 [i0 eval {namespace eval ::ctx1 { + ::ns::x1 + }}] + + set r2 [i0 eval {namespace eval ::ctx2 { + ::ns::x2 + }}] + + set r3 [i0 eval {namespace eval ::ctx1 { + ::ns::x1 + }}] + + return [list $r1 $r2 $r3] +} -cleanup { + testinterpresolver down i0 + interp delete i0 +} -result {yy YY yy} + cleanupTests return 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 859f352..e43ce12 100644 --- a/tests/safe.test +++ b/tests/safe.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. -package require Tcl 8.5 +package require Tcl 8.5- if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -174,7 +174,7 @@ test safe-6.3 {test safe interpreters knowledge of the world} { } set r [lsearch -all -inline -not -exact $r "threaded"] lsort $r -} {byteOrder pathSeparator platform pointerSize wordSize} +} {byteOrder engine pathSeparator platform pointerSize wordSize} # More test should be added to check that hostname, nameofexecutable, aren't # leaking infos, but they still do... @@ -211,8 +211,8 @@ test safe-7.3 {check that safe subinterpreters work} { } {ok {} 0} # test source control on file name +set i "a" test safe-8.1 {safe source control on file} -setup { - set i "a" catch {safe::interpDelete $i} } -body { safe::interpCreate $i @@ -221,7 +221,6 @@ test safe-8.1 {safe source control on file} -setup { safe::interpDelete $i } -result {wrong # args: should be "source ?-encoding E? fileName"} test safe-8.2 {safe source control on file} -setup { - set i "a" catch {safe::interpDelete $i} } -body { safe::interpCreate $i @@ -230,7 +229,6 @@ test safe-8.2 {safe source control on file} -setup { safe::interpDelete $i } -result {wrong # args: should be "source ?-encoding E? fileName"} test safe-8.3 {safe source control on file} -setup { - set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {lappend ::log $str} @@ -245,7 +243,6 @@ test safe-8.3 {safe source control on file} -setup { safe::interpDelete $i } -result {1 {permission denied} {{ERROR for slave a : ".": is a directory}}} test safe-8.4 {safe source control on file} -setup { - set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} @@ -260,7 +257,6 @@ test safe-8.4 {safe source control on file} -setup { safe::interpDelete $i } -result {1 {permission denied} {{ERROR for slave a : "/abc/def": not in access_path}}} test safe-8.5 {safe source control on file} -setup { - set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} @@ -279,7 +275,6 @@ test safe-8.5 {safe source control on file} -setup { safe::interpDelete $i } -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah]:no such file or directory"]] test safe-8.6 {safe source control on file} -setup { - set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} @@ -296,7 +291,6 @@ test safe-8.6 {safe source control on file} -setup { safe::interpDelete $i } -result [list 1 {no such file or directory} [list "ERROR for slave a : [file join [info library] blah.tcl]:no such file or directory"]] test safe-8.7 {safe source control on file} -setup { - set i "a" catch {safe::interpDelete $i} set log {} proc safe-test-log {str} {global log; lappend log $str} @@ -315,7 +309,6 @@ test safe-8.7 {safe source control on file} -setup { 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 { - set i "a" catch {safe::interpDelete $i} safe::interpCreate $i } -body { @@ -349,8 +342,8 @@ test safe-8.10 {safe source and return} -setup { removeFile $returnScript } -result ok +set i "a" test safe-9.1 {safe interps' deleteHook} -setup { - set i "a" catch {safe::interpDelete $i} set res {} } -body { @@ -365,7 +358,6 @@ test safe-9.1 {safe interps' deleteHook} -setup { list [interp eval $i exit] $res } -result {{} {arg1 arg2 a}} test safe-9.2 {safe interps' error in deleteHook} -setup { - set i "a" catch {safe::interpDelete $i} set res {} set log {} @@ -531,14 +523,14 @@ test safe-11.7.1 {testing safe encoding} -setup { } -body { catch {interp eval $i encoding convertfrom} m o dict get $o -errorinfo -} -returnCodes ok -cleanup { +} -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i } -result {wrong # args: should be "encoding convertfrom ?encoding? data" while executing "encoding convertfrom" invoked from within -"::interp invokehidden interp1 encoding convertfrom" +"::interp invokehidden interp* encoding convertfrom" invoked from within "encoding convertfrom" invoked from within @@ -555,14 +547,14 @@ test safe-11.8.1 {testing safe encoding} -setup { } -body { catch {interp eval $i encoding convertto} m o dict get $o -errorinfo -} -returnCodes ok -cleanup { +} -returnCodes ok -match glob -cleanup { unset -nocomplain m o safe::interpDelete $i } -result {wrong # args: should be "encoding convertto ?encoding? data" while executing "encoding convertto" invoked from within -"::interp invokehidden interp1 encoding convertto" +"::interp invokehidden interp* encoding convertto" invoked from within "encoding convertto" invoked from within diff --git a/tests/scan.test b/tests/scan.test index b57b641..8ddb595 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -535,6 +535,25 @@ test scan-5.13 {integer scanning and overflow} { test scan-5.14 {integer scanning} { scan 0xff %u } 0 +test scan-5.15 {Bug be003d570f} { + scan 0x40 %o +} 0 +test scan-5.16 {Bug be003d570f} { + scan 0x40 %b +} 0 +test scan-5.17 {bigint scanning} -setup { + set a {}; set b {}; set c {}; set d {} +} -body { + list [scan "207698809136909011942886895,207698809136909011942886895,abcdef0123456789abcdef,125715736004432126361152746757" \ + %llu,%lld,%llx,%llo a b c d] $a $b $c $d +} -result {4 207698809136909011942886895 207698809136909011942886895 207698809136909011942886895 207698809136909011942886895} +test scan-5.18 {bigint scanning underflow} -setup { + set a {}; +} -body { + list [scan "-207698809136909011942886895" \ + %llu a] $a +} -returnCodes 1 -result {unsigned bignum scans are invalid} + 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 94b6901..309abaf 100644 --- a/tests/set-old.test +++ b/tests/set-old.test @@ -14,7 +14,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2 namespace import -force ::tcltest::* } @@ -652,6 +652,13 @@ test set-old-8.52 {array command, array names -regexp on regexp pattern} { set a(11) 1 list [catch {lsort [array names a -regexp ^1]} msg] $msg } {0 {1*2 11 12}} +test set-old-8.52.1 {array command, array names -regexp, backrefs} { + catch {unset a} + set a(1*2) 1 + set a(12) 1 + set a(11) 1 + list [catch {lsort [array names a -regexp {^(.)\1}]} msg] $msg +} {0 11} test set-old-8.53 {array command, array names -regexp} { catch {unset a} set a(-glob) 1 @@ -865,6 +872,8 @@ test set-old-10.13 {array enumeration errors} { list [catch {array done a b c} msg] $msg } {1 {wrong # args: should be "array donesearch arrayName searchId"}} test set-old-10.14 {array enumeration errors} { + catch {unset a} + set a(a) a list [catch {array done a b} msg] $msg } {1 {illegal search identifier "b"}} test set-old-10.15 {array enumeration errors} { @@ -931,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 18119f5..3c87000 100644 --- a/tests/set.test +++ b/tests/set.test @@ -22,7 +22,7 @@ testConstraint testset2 [llength [info commands testset2]] catch {unset x} catch {unset i} - + test set-1.1 {TclCompileSetCmd: missing variable name} { list [catch {set} msg] $msg } {1 {wrong # args: should be "set varName ?newValue?"}} @@ -39,16 +39,18 @@ test set-1.4 {TclCompileSetCmd: simple variable name in quotes} { set i 17 list [set "i"] $i } {17 17} -test set-1.5 {TclCompileSetCmd: simple variable name in braces} { +test set-1.5 {TclCompileSetCmd: simple variable name in braces} -setup { catch {unset {a simple var}} +} -body { set {a simple var} 27 list [set {a simple var}] ${a simple var} -} {27 27} -test set-1.6 {TclCompileSetCmd: simple array variable name} { +} -result {27 27} +test set-1.6 {TclCompileSetCmd: simple array variable name} -setup { catch {unset a} +} -body { set a(foo) 37 list [set a(foo)] $a(foo) -} {37 37} +} -result {37 37} test set-1.7 {TclCompileSetCmd: non-simple (computed) variable name} { set x "i" set i 77 @@ -149,22 +151,24 @@ test set-1.14 {TclCompileSetCmd: simple local name, >255 locals} { } 260locals } {1234} -test set-1.15 {TclCompileSetCmd: variable is array} { +test set-1.15 {TclCompileSetCmd: variable is array} -setup { catch {unset a} +} -body { set x 27 set x [set a(foo) 11] catch {unset a} set x -} 11 -test set-1.16 {TclCompileSetCmd: variable is array, elem substitutions} { +} -result 11 +test set-1.16 {TclCompileSetCmd: variable is array, elem substitutions} -setup { catch {unset a} +} -body { set i 5 set x 789 set a(foo5) 27 set x [set a(foo$i)] catch {unset a} set x -} 27 +} -result 27 test set-1.17 {TclCompileSetCmd: doing assignment, simple int} { set i 5 @@ -211,7 +215,7 @@ test set-1.25 {TclCompileSetCmd: var is array, braced (no subs)} { test set-1.26 {TclCompileSetCmd: various array constructs} { # Test all kinds of array constructs that TclCompileSetCmd # may feel inclined to tamper with. - proc p {} { + apply {{} { set a x set be(hej) 1 ; # hej set be($a) 1 ; # x @@ -230,28 +234,33 @@ test set-1.26 {TclCompileSetCmd: various array constructs} { set [string range bet 0 1](foo) 1 ; # foo set be([set be(a:$a)][set b\e($a)]) 1 ; # 51 return [lsort [array names be]] - } - p + }} } [lsort {hej x $a x,hej x,x c(x ww a:x hej,1,hej hug {a a} {x ,ugg,hej} x,h"ej {b c} foo 51}]; # " just a matching end quote -test set-2.1 {set command: runtime error, bad variable name} { +test set-2.1 {set command: runtime error, bad variable name} -setup { unset -nocomplain {"foo} +} -body { list [catch {set {"foo}} msg] $msg $::errorInfo -} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable +} -result {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable while executing "set {"foo}"}} -test set-2.2 {set command: runtime error, not array variable} { - catch {unset b} +# Stop my editor highlighter " from being confused +test set-2.2 {set command: runtime error, not array variable} -setup { + unset -nocomplain b +} -body { set b 44 list [catch {set b(123)} msg] $msg -} {1 {can't read "b(123)": variable isn't array}} -test set-2.3 {set command: runtime error, errors in reading variables} { - catch {unset a} +} -result {1 {can't read "b(123)": variable isn't array}} +test set-2.3 {set command: runtime error, errors in reading variables} -setup { + unset -nocomplain a +} -body { set a(6) 44 list [catch {set a(18)} msg] $msg -} {1 {can't read "a(18)": no such element in array}} -test set-2.4 {set command: runtime error, readonly variable} -body { +} -result {1 {can't read "a(18)": no such element in array}} +test set-2.4 {set command: runtime error, readonly variable} -setup { + unset -nocomplain x +} -body { proc readonly args {error "variable is read-only"} set x 123 trace var x w readonly @@ -260,12 +269,18 @@ test set-2.4 {set command: runtime error, readonly variable} -body { while executing * "set x 1"}} -test set-2.5 {set command: runtime error, basic array operations} { +test set-2.5 {set command: runtime error, basic array operations} -setup { + unset -nocomplain a +} -body { + array set a {} list [catch {set a(other)} msg] $msg -} {1 {can't read "a(other)": no such element in array}} -test set-2.6 {set command: runtime error, basic array operations} { +} -result {1 {can't read "a(other)": no such element in array}} +test set-2.6 {set command: runtime error, basic array operations} -setup { + unset -nocomplain a +} -body { + array set a {} list [catch {set a} msg] $msg -} {1 {can't read "a": variable is array}} +} -result {1 {can't read "a": variable is array}} # Test the uncompiled version of set @@ -479,25 +494,29 @@ test set-3.24 {uncompiled set command: too many arguments} { $z msg } {wrong # args: should be "set varName ?newValue?"} -test set-4.1 {uncompiled set command: runtime error, bad variable name} { +test set-4.1 {uncompiled set command: runtime error, bad variable name} -setup { unset -nocomplain {"foo} +} -body { set z set list [catch {$z {"foo}} msg] $msg $::errorInfo -} {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable +} -result {1 {can't read ""foo": no such variable} {can't read ""foo": no such variable while executing "$z {"foo}"}} -test set-4.2 {uncompiled set command: runtime error, not array variable} { - set z set +# Stop my editor highlighter " from being confused +test set-4.2 {uncompiled set command: runtime error, not array variable} -setup { catch {unset b} +} -body { + set z set $z b 44 list [catch {$z b(123)} msg] $msg -} {1 {can't read "b(123)": variable isn't array}} -test set-4.3 {uncompiled set command: runtime error, errors in reading variables} { - set z set - catch {unset a} +} -result {1 {can't read "b(123)": variable isn't array}} +test set-4.3 {uncompiled set command: runtime error, errors in reading variables} -setup { + catch {unset a} +} -body { + set z set $z a(6) 44 list [catch {$z a(18)} msg] $msg -} {1 {can't read "a(18)": no such element in array}} +} -result {1 {can't read "a(18)": no such element in array}} test set-4.4 {uncompiled set command: runtime error, readonly variable} -body { set z set proc readonly args {error "variable is read-only"} @@ -508,27 +527,33 @@ test set-4.4 {uncompiled set command: runtime error, readonly variable} -body { while executing * "$z x 1"}} -test set-4.5 {uncompiled set command: runtime error, basic array operations} { +test set-4.5 {uncompiled set command: runtime error, basic array operations} -setup { + unset -nocomplain a + array set a {} +} -body { set z set list [catch {$z a(other)} msg] $msg -} {1 {can't read "a(other)": no such element in array}} -test set-4.6 {set command: runtime error, basic array operations} { +} -result {1 {can't read "a(other)": no such element in array}} +test set-4.6 {set command: runtime error, basic array operations} -setup { + unset -nocomplain a + array set a {} +} -body { set z set list [catch {$z a} msg] $msg -} {1 {can't read "a": variable is array}} +} -result {1 {can't read "a": variable is array}} -test set-5.1 {error on malformed array name} testset2 { +test set-5.1 {error on malformed array name} -constraints testset2 -setup { unset -nocomplain z +} -body { catch {testset2 z(a) b} msg catch {testset2 z(b) a} msg1 list $msg $msg1 -} {{can't read "z(a)(b)": variable isn't array} {can't read "z(b)(a)": variable isn't array}} - +} -result {{can't read "z(a)(b)": variable isn't array} {can't read "z(b)(a)": variable isn't array}} # In a mem-debug build, this test will crash unless Bug 3602706 is fixed. test set-5.2 {Bug 3602706} -body { testset2 ::tcl_platform not-in-there } -returnCodes error -result * -match glob - + # cleanup catch {unset a} catch {unset b} @@ -536,4 +561,8 @@ catch {unset i} catch {unset x} catch {unset z} ::tcltest::cleanupTests -return +return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/socket.test b/tests/socket.test index 8473602..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-}]}] @@ -69,7 +74,30 @@ testConstraint exec [llength [info commands exec]] # Produce a random port number in the Dynamic/Private range # from 49152 through 65535. -proc randport {} { expr {int(rand()*16383+49152)} } +proc randport {} { + # firstly try dynamic port via server-socket(0): + set port 0x7fffffff + catch { + set port [lindex [fconfigure [set s [socket -server {} 0]] -sockname] 2] + close $s + } + while {[catch { + close [socket -server {} $port] + } msg]} { + if {[incr i] > 1000} {return -code error "too many iterations to get free random port: $msg"} + # try random port: + set port [expr {int(rand()*16383+49152)}] + } + 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 @@ -265,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} @@ -280,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"} @@ -302,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] @@ -1782,7 +1828,6 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -body { set i 0 vwait x close $f - thread::wait }]] set port [thread::send $serverthread {set listen}] set s [socket $localhost $port] @@ -2249,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 @@ -2361,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/split.test b/tests/split.test index 778131f..585fef5 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 3611753..11cbcff 100644 --- a/tests/string.test +++ b/tests/string.test @@ -219,7 +219,7 @@ test string-4.14 {string first, negative start index} { } 1 test string-4.15 {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] + # 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 @@ -419,7 +419,7 @@ test string-6.37 {string is double, false on int overflow} -setup { } -result {1 priorValue} # string-6.38 removed, underflow on input is no longer an error. test string-6.39 {string is double, false} { - # This test is non-portable because IRIX thinks + # 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 # @@ -756,13 +756,13 @@ 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?"}} +} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}} test string-7.2 {string last, bad args} { list [catch {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?"}} +} {1 {wrong # args: should be "string last needleString haystackString ?lastIndex?"}} test string-7.4 {string last} { string la xxx xxxx123xx345x678 } 1 @@ -901,6 +901,10 @@ test string-10.20 {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] } {XY XY 2 XY} +test string-10.20.1 {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] +} {ZZZ XXX 2 XXX} test string-10.21 {string map, ABR checks} { string map {longstring foob} long } long @@ -1833,7 +1837,7 @@ proc MemStress {args} { set res {} foreach body $args { set end 0 - for {set i 0} {$i < 5} {incr i} { + for {set i 0} {$i < 5} {incr i} { proc MemStress_Body {} $body uplevel 1 MemStress_Body rename MemStress_Body {} diff --git a/tests/stringComp.test b/tests/stringComp.test index a66525e..2aeb08e 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -728,6 +728,19 @@ test stringComp-14.3 {Bug 0dca3bfa8f} { 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 diff --git a/tests/stringObj.test b/tests/stringObj.test index 8209142..49f268e 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" 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..ce506a7 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 diff --git a/tests/tcltest.test b/tests/tcltest.test index e66678b..728a018 100644 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -46,6 +46,7 @@ makeFile { cd [temporaryDirectory] testConstraint exec [llength [info commands exec]] + # test -help # Child processes because -help [exit]s. test tcltest-1.1 {tcltest -help} {exec} { @@ -1824,9 +1825,13 @@ test tcltest-26.2 {Bug/RFE 1017151} -setup { ---- errorInfo: body error * ---- errorInfo(cleanup): cleanup error*} - + cleanupTests } namespace delete ::tcltest::test return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/tm.test b/tests/tm.test index 1b22f8c..567d351 100644 --- a/tests/tm.test +++ b/tests/tm.test @@ -6,7 +6,7 @@ # Copyright (c) 2004 by Donal K. Fellows. # All rights reserved. -package require Tcl 8.5 +package require Tcl 8.5- if {"::tcltest" ni [namespace children]} { package require tcltest 2 namespace import -force ::tcltest::* @@ -200,7 +200,7 @@ test tm-3.11 {tm: module path management, remove ignores unknown path} -setup { proc genpaths {base} { # Normalizing picks up drive letters on windows [Bug 1053568] set base [file normalize $base] - lassign [split [package present Tcl] .] major minor + lassign [split [package present Tcl] .] major minor set results {} set base [file join $base tcl$major] lappend results [file join $base site-tcl] 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/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/unixNotfy.test b/tests/unixNotfy.test index 2f03529..18b967f 100644 --- a/tests/unixNotfy.test +++ b/tests/unixNotfy.test @@ -34,7 +34,7 @@ test unixNotfy-1.1 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} - 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 } } @@ -90,7 +90,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/unload.test b/tests/unload.test index 5a374c4..73f1091 100644 --- a/tests/unload.test +++ b/tests/unload.test @@ -45,6 +45,14 @@ testConstraint teststaticpkg [llength [info commands teststaticpkg]] testConstraint testsimplefilesystem \ [llength [info commands testsimplefilesystem]] +proc loadIfNotPresent {pkg args} { + global testDir ext + set loaded [lmap x [info loaded {*}$args] {lindex $x 1}] + if {[string totitle $pkg] ni $loaded} { + load [file join $testDir $pkg$ext] + } +} + # Basic tests: parameter testing... test unload-1.1 {basic errors} -returnCodes error -body { unload @@ -73,7 +81,7 @@ set pkgua_detached {} set pkgua_unloaded {} # Tests for loading/unloading in trusted (non-safe) interpreters... test unload-2.1 {basic loading of non-unloadable package, with guess for package name} [list $dll $loaded] { - load [file join $testDir pkga$ext] + loadIfNotPresent pkga list [pkga_eq abc def] [lsort [info commands pkga_*]] } {0 {pkga_eq pkga_quote}} test unload-2.2 {basic loading of unloadable package, with guess for package name} [list $dll $loaded] { @@ -82,28 +90,43 @@ test unload-2.2 {basic loading of unloadable package, with guess for package nam [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded } {{} {} {} {} 0 {pkgua_eq pkgua_quote} . {} {}} -test unload-2.3 {basic unloading of non-unloadable package, with guess for package name} [list $dll $loaded] { - list [catch {unload [file join $testDir pkga$ext]} msg] \ - [string map [list [file join $testDir pkga$ext] file] $msg] -} {1 {file "file" cannot be unloaded under a trusted interpreter}} -test unload-2.4 {basic unloading of unloadable package, with guess for package name} [list $dll $loaded] { +test unload-2.3 {basic unloading of non-unloadable package, with guess for package name} -setup { + loadIfNotPresent pkga +} -constraints [list $dll $loaded] -returnCodes error -match glob -body { + unload [file join $testDir pkga$ext] +} -result {file "*" cannot be unloaded under a trusted interpreter} +test unload-2.4 {basic unloading of unloadable package, with guess for package name} -setup { + loadIfNotPresent pkgua +} -constraints [list $dll $loaded] -body { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ [unload [file join $testDir pkgua$ext]] \ [info commands pkgua_*] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded -} {. {} {} {} {} . . .} -test unload-2.5 {reloading of unloaded package, with guess for package name} [list $dll $loaded] { +} -result {. {} {} {} {} . . .} +test unload-2.5 {reloading of unloaded package, with guess for package name} -setup { + if {$pkgua_loaded eq ""} { + loadIfNotPresent pkgua + unload [file join $testDir pkgua$ext] + } +} -constraints [list $dll $loaded] -body { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ [load [file join $testDir pkgua$ext]] \ [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded -} {. . . {} 0 {pkgua_eq pkgua_quote} .. . .} -test unload-2.6 {basic unloading of re-loaded package, with guess for package name} [list $dll $loaded] { +} -result {. . . {} 0 {pkgua_eq pkgua_quote} .. . .} +test unload-2.6 {basic unloading of re-loaded package, with guess for package name} -setup { + # Establish expected state + if {$pkgua_loaded eq ""} { + loadIfNotPresent pkgua + unload [file join $testDir pkgua$ext] + load [file join $testDir pkgua$ext] + } +} -constraints [list $dll $loaded] -body { list $pkgua_loaded $pkgua_detached $pkgua_unloaded \ [unload [file join $testDir pkgua$ext]] \ [info commands pkgua_*] \ $pkgua_loaded $pkgua_detached $pkgua_unloaded -} {.. . . {} {} .. .. ..} +} -result {.. . . {} {} .. .. ..} # Tests for loading/unloading in safe interpreters... interp create -safe child @@ -127,38 +150,52 @@ test unload-3.2 {basic loading of unloadable package in a safe interpreter, with [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] } {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} -test unload-3.3 {unloading of a package that has never been loaded from a safe interpreter} \ - [list $dll $loaded] { - list [catch {unload [file join $testDir pkga$ext] {} child} msg] \ - [string map [list [file join $testDir pkga$ext] file] $msg] -} {1 {file "file" has never been loaded in this interpreter}} -test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for package name} \ - [list $dll $loaded] { - list [catch {unload [file join $testDir pkgb$ext] {} child} msg] \ - [string map [list [file join $testDir pkgb$ext] file] $msg] -} {1 {file "file" cannot be unloaded under a safe interpreter}} -test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for package name} \ - [list $dll $loaded] { +test unload-3.3 {unloading of a package that has never been loaded from a safe interpreter} -setup { + loadIfNotPresent pkga +} -constraints [list $dll $loaded] -returnCodes error -match glob -body { + unload [file join $testDir pkga$ext] {} child +} -result {file "*" has never been loaded in this interpreter} +test unload-3.4 {basic unloading of a non-unloadable package from a safe interpreter, with guess for package name} -setup { + if {[lsearch -index 1 [info loaded child] Pkgb] == -1} { + load [file join $testDir pkgb$ext] pKgB child + } +} -constraints [list $dll $loaded] -returnCodes error -match glob -body { + unload [file join $testDir pkgb$ext] {} child +} -result {file "*" cannot be unloaded under a safe interpreter} +test unload-3.5 {basic unloading of an unloadable package from a safe interpreter, with guess for package name} -setup { + if {[lsearch -index 1 [info loaded child] Pkgua] == -1} { + load [file join $testDir pkgua$ext] pkgua child + } +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [unload [file join $testDir pkgua$ext] {} child] \ [child eval info commands pkgua_*] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{. {} {}} {} {} {. . .}} -test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess for package name} \ - [list $dll $loaded] { +} -result {{. {} {}} {} {} {. . .}} +test unload-3.6 {reloading of unloaded package in a safe interpreter, with guess for package name} -setup { + if {[child eval set pkgua_loaded] eq ""} { + load [file join $testDir pkgua$ext] {} child + unload [file join $testDir pkgua$ext] {} child + } +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [load [file join $testDir pkgua$ext] {} child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{. . .} {} 0 {pkgua_eq pkgua_quote} {.. . .}} -test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, with package name conversion} \ - [list $dll $loaded] { +} -result {{. . .} {} 0 {pkgua_eq pkgua_quote} {.. . .}} +test unload-3.7 {basic unloading of re-loaded package from a safe interpreter, with package name conversion} -setup { + if {[child eval set pkgua_loaded] eq ""} { + load [file join $testDir pkgua$ext] {} child + unload [file join $testDir pkgua$ext] {} child + load [file join $testDir pkgua$ext] {} child + } +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [unload [file join $testDir pkgua$ext] pKgUa child] \ [child eval info commands pkgua_*] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{.. . .} {} {} {.. .. ..}} +} -result {{.. . .} {} {} {.. .. ..}} # Tests for loading/unloading of a package among multiple interpreters... interp create child-trusted @@ -167,56 +204,89 @@ child-trusted eval { set pkgua_detached {} set pkgua_unloaded {} } +array set load {M 0 C 0 T 0} ## Load package in main trusted interpreter... -test unload-4.1 {loading of unloadable package in trusted interpreter, with guess for package name} \ - [list $dll $loaded] { +test unload-4.1 {loading of unloadable package in trusted interpreter, with guess for package name} -setup { + set pkgua_loaded "" + set pkgua_detached "" + set pkgua_unloaded "" + incr load(M) +} -constraints [list $dll $loaded] -body { list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \ [load [file join $testDir pkgua$ext]] \ [pkgua_eq abc def] [lsort [info commands pkgua_*]] \ [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] -} {{.. .. ..} {} 0 {pkgua_eq pkgua_quote} {... .. ..}} +} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} ## Load package in child-safe interpreter... -test unload-4.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} \ - [list $dll $loaded] { +test unload-4.2 {basic loading of unloadable package in a safe interpreter, with package name conversion} -setup { + child eval { + set pkgua_loaded "" + set pkgua_detached "" + set pkgua_unloaded "" + } + incr load(C) +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [load [file join $testDir pkgua$ext] pKgUA child] \ [child eval pkgua_eq abc def] \ [lsort [child eval info commands pkgua_*]] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{.. .. ..} {} 0 {pkgua_eq pkgua_quote} {... .. ..}} +} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} ## Load package in child-trusted interpreter... -test unload-4.3 {basic loading of unloadable package in a second trusted interpreter, with package name conversion} \ - [list $dll $loaded] { +test unload-4.3 {basic loading of unloadable package in a second trusted interpreter, with package name conversion} -setup { + incr load(T) +} -constraints [list $dll $loaded] -body { list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [load [file join $testDir pkgua$ext] pkguA child-trusted] \ [child-trusted eval pkgua_eq abc def] \ [lsort [child-trusted eval info commands pkgua_*]] \ [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} +} -result {{{} {} {}} {} 0 {pkgua_eq pkgua_quote} {. {} {}}} ## Unload the package from the main trusted interpreter... -test unload-4.4 {basic unloading of unloadable package from trusted interpreter, with guess for package name} \ - [list $dll $loaded] { +test unload-4.4 {basic unloading of unloadable package from trusted interpreter, with guess for package name} -setup { + if {!$load(M)} { + load [file join $testDir pkgua$ext] + } + if {!$load(C)} { + load [file join $testDir pkgua$ext] {} child + incr load(C) + } + if {!$load(T)} { + load [file join $testDir pkgua$ext] {} child-trusted + incr load(T) + } +} -constraints [list $dll $loaded] -body { list [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] \ [unload [file join $testDir pkgua$ext]] \ [info commands pkgua_*] \ [list $pkgua_loaded $pkgua_detached $pkgua_unloaded] -} {{... .. ..} {} {} {... ... ..}} +} -result {{. {} {}} {} {} {. . {}}} ## Unload the package from the child safe interpreter... -test unload-4.5 {basic unloading of unloadable package from a safe interpreter, with guess for package name} \ - [list $dll $loaded] { +test unload-4.5 {basic unloading of unloadable package from a safe interpreter, with guess for package name} -setup { + if {!$load(C)} { + load [file join $testDir pkgua$ext] {} child + } + if {!$load(T)} { + load [file join $testDir pkgua$ext] {} child-trusted + incr load(T) + } +} -constraints [list $dll $loaded] -body { list [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [unload [file join $testDir pkgua$ext] {} child] \ [child eval info commands pkgua_*] \ [child eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{... .. ..} {} {} {... ... ..}} +} -result {{. {} {}} {} {} {. . {}}} ## Unload the package from the child trusted interpreter... -test unload-4.6 {basic unloading of unloadable package from a safe interpreter, with guess for package name} \ - [list $dll $loaded] { +test unload-4.6 {basic unloading of unloadable package from a safe interpreter, with guess for package name} -setup { + if {!$load(T)} { + load [file join $testDir pkgua$ext] {} child-trusted + } +} -constraints [list $dll $loaded] -body { list [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] \ [unload [file join $testDir pkgua$ext] {} child-trusted] \ [child-trusted eval info commands pkgua_*] \ [child-trusted eval {list $pkgua_loaded $pkgua_detached $pkgua_unloaded}] -} {{. {} {}} {} {} {. . .}} +} -result {{. {} {}} {} {} {. . .}} test unload-5.1 {unload a module loaded from vfs} \ -constraints [list $dll $loaded testsimplefilesystem] \ @@ -230,9 +300,7 @@ test unload-5.1 {unload a module loaded from vfs} \ list [catch {unload simplefs:/pkgua$ext} msg] $msg } \ -result {0 {}} - - - + # cleanup interp delete child interp delete child-trusted diff --git a/tests/uplevel.test b/tests/uplevel.test index 0410469..737c571 100644 --- a/tests/uplevel.test +++ b/tests/uplevel.test @@ -101,6 +101,105 @@ test uplevel-4.4 {error: not enough args} -returnCodes error -body { uplevel 1 }} } -result {wrong # args: should be "uplevel ?level? command ?arg ...?"} +test uplevel-4.5 {level parsing} { + apply {{} {uplevel 0 {}}} +} {} +test uplevel-4.6 {level parsing} { + apply {{} {uplevel #0 {}}} +} {} +test uplevel-4.7 {level parsing} { + apply {{} {uplevel [expr 0] {}}} +} {} +test uplevel-4.8 {level parsing} { + apply {{} {uplevel #[expr 0] {}}} +} {} +test uplevel-4.9 {level parsing} { + apply {{} {uplevel -0 {}}} +} {} +test uplevel-4.10 {level parsing} { + apply {{} {uplevel #-0 {}}} +} {} +test uplevel-4.11 {level parsing} { + apply {{} {uplevel [expr -0] {}}} +} {} +test uplevel-4.12 {level parsing} { + apply {{} {uplevel #[expr -0] {}}} +} {} +test uplevel-4.13 {level parsing} { + apply {{} {uplevel 1 {}}} +} {} +test uplevel-4.14 {level parsing} { + apply {{} {uplevel #1 {}}} +} {} +test uplevel-4.15 {level parsing} { + apply {{} {uplevel [expr 1] {}}} +} {} +test uplevel-4.16 {level parsing} { + apply {{} {uplevel #[expr 1] {}}} +} {} +test uplevel-4.17 {level parsing} { + apply {{} {uplevel -0xffffffff {}}} +} {} +test uplevel-4.18 {level parsing} { + apply {{} {uplevel #-0xffffffff {}}} +} {} +test uplevel-4.19 {level parsing} { + apply {{} {uplevel [expr -0xffffffff] {}}} +} {} +test uplevel-4.20 {level parsing} { + apply {{} {uplevel #[expr -0xffffffff] {}}} +} {} +test uplevel-4.21 {level parsing} -body { + apply {{} {uplevel -1 {}}} +} -returnCodes error -result {invalid command name "-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"} +test uplevel-4.24 {level parsing} -body { + apply {{} {uplevel #[expr -1] {}}} +} -returnCodes error -result {bad level "#-1"} +test uplevel-4.25 {level parsing} -body { + apply {{} {uplevel 0xffffffff {}}} +} -returnCodes error -result {bad level "0xffffffff"} +test uplevel-4.26 {level parsing} -body { + apply {{} {uplevel #0xffffffff {}}} +} -returnCodes error -result {bad level "#0xffffffff"} +test uplevel-4.27 {level parsing} -body { + apply {{} {uplevel [expr 0xffffffff] {}}} +} -returnCodes error -result {bad level "4294967295"} +test uplevel-4.28 {level parsing} -body { + apply {{} {uplevel #[expr 0xffffffff] {}}} +} -returnCodes error -result {bad level "#4294967295"} +test uplevel-4.29 {level parsing} -body { + apply {{} {uplevel 0.2 {}}} +} -returnCodes error -result {bad level "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"} +test uplevel-4.32 {level parsing} -body { + apply {{} {uplevel #[expr 0.2] {}}} +} -returnCodes error -result {bad level "#0.2"} +test uplevel-4.33 {level parsing} -body { + apply {{} {uplevel .2 {}}} +} -returnCodes error -result {invalid command name ".2"} +test uplevel-4.34 {level parsing} -body { + apply {{} {uplevel #.2 {}}} +} -returnCodes error -result {bad level "#.2"} +test uplevel-4.35 {level parsing} -body { + apply {{} {uplevel [expr .2] {}}} +} -returnCodes error -result {bad level "0.2"} +test uplevel-4.36 {level parsing} -body { + apply {{} {uplevel #[expr .2] {}}} +} -returnCodes error -result {bad level "#0.2"} + + + proc a2 {} { uplevel a3 @@ -138,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 @@ -157,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 @@ -181,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 ceb1af7..a03dd6c 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -302,7 +302,7 @@ test utf-21.1 {TclUniCharIsAlnum} { } {1} test utf-21.2 {unicode alnum char in regc_locale.c} { # this returns 1 with Unicode 7 compliance - list [regexp {^[[:alnum:]]+$} \u1040\u021f\u0220] [regexp {^\w+$} \u1040\u021f\u0220] + list [regexp {^[[:alnum:]]+$} \u1040\u021f\u0220] [regexp {^\w+$} \u1040\u021f\u0220_\u203f\u2040\u2054\ufe33\ufe34\ufe4d\ufe4e\ufe4f\uff3f] } {1 1} test utf-21.3 {unicode print char in regc_locale.c} { # this returns 1 with Unicode 7 compliance diff --git a/tests/util.test b/tests/util.test index 7782f35..22d120b 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] @@ -208,7 +209,7 @@ test util-4.6 {Tcl_ConcatObj - utf-8 sequence with "whitespace" char} { } \xe0 test util-4.7 {Tcl_ConcatObj - refCount safety} testconcatobj { # Check for Bug #1447328 (actually, bugs in its original "fix"). One of the - # symptoms was Bug #2055782. + # symptoms was Bug #2055782. testconcatobj } {} @@ -566,7 +567,7 @@ test util-9.1.3 {TclGetIntForIndex} { } k test util-9.2.0 {TclGetIntForIndex} { string index abcd end -} d +} d test util-9.2.1 {TclGetIntForIndex} -body { string index abcd { end} } -returnCodes error -match glob -result * @@ -4007,7 +4008,7 @@ test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} { } set r } [list {*}{ - 0x43fffffffffffffc 0xc3fffffffffffffc + 0x43fffffffffffffc 0xc3fffffffffffffc 0x43fffffffffffffc 0xc3fffffffffffffc 0x43fffffffffffffd 0xc3fffffffffffffd 0x43fffffffffffffe 0xc3fffffffffffffe @@ -4017,6 +4018,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 0531746..9816d98 100644 --- a/tests/var.test +++ b/tests/var.test @@ -26,6 +26,21 @@ testConstraint testupvar [llength [info commands testupvar]] testConstraint testgetvarfullname [llength [info commands testgetvarfullname]] testConstraint testsetnoerr [llength [info commands testsetnoerr]] testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + return [lindex [split [memory info] \n] 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}] + } +} + catch {rename p ""} catch {namespace delete test_ns_var} @@ -39,15 +54,17 @@ 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) } -result {11 11 38 38} +set ::x "global value" +namespace eval test_ns_var { + variable x "namespace value" +} test var-1.2 {TclLookupVar, TCL_GLOBAL_ONLY implies global namespace var} { - set x "global value" namespace eval test_ns_var { - variable x "namespace value" proc p {} { global x ;# specifies TCL_GLOBAL_ONLY to get global x return $x @@ -167,7 +184,9 @@ test var-1.17 {TclLookupVar, resurrect array element via upvar to deleted array: set result } } {0 2 1 {can't set "foo": upvar refers to element in deleted array}} -test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} { +test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: uncompiled code path} -setup { + unset -nocomplain test_ns_var::x +} -body { namespace eval test_ns_var { variable result {} variable x @@ -179,7 +198,7 @@ test var-1.18 {TclLookupVar, resurrect array element via upvar to deleted array: namespace delete [namespace current] set result } -} {0 2 1 {can't set "foo": upvar refers to element in deleted array}} +} -result {0 2 1 {can't set "foo": upvar refers to element in deleted array}} test var-1.19 {TclLookupVar, right error message when parsing variable name} -body { [format set] thisvar(doesntexist) } -returnCodes error -result {can't read "thisvar(doesntexist)": no such variable} @@ -216,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} @@ -228,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 } @@ -261,6 +280,7 @@ test var-3.7 {MakeUpvar, my var has ::s} -setup { } } -result {789789} test var-3.8 {MakeUpvar, my var already exists in global ns} -setup { + upvar #0 aaaaa xxxxx catch {unset aaaaa} catch {unset xxxxx} } -body { @@ -274,6 +294,8 @@ test var-3.9 {MakeUpvar, my var has invalid ns name} -setup { } -returnCodes error -body { set aaaaa 789789 upvar #0 aaaaa test_ns_fred::lnk +} -cleanup { + unset ::aaaaa } -result {can't create "test_ns_fred::lnk": parent namespace doesn't exist} test var-3.10 {MakeUpvar, between namespaces} -body { namespace eval {} { @@ -282,8 +304,6 @@ test var-3.10 {MakeUpvar, between namespaces} -body { set foo::bar 1 list $bar $foo::bar } -} -cleanup { - unset ::aaaaa } -result {1 1} test var-3.11 {MakeUpvar, my var looks like array elem} -setup { catch {unset aaaaa} @@ -322,9 +342,11 @@ test var-5.2 {Tcl_GetVariableFullName, namespace variable} { namespace which -variable martha } } {::test_ns_var::martha} -test var-5.3 {Tcl_GetVariableFullName, namespace variable} { +test var-5.3 {Tcl_GetVariableFullName, namespace variable} -setup { + namespace eval test_ns_var {variable martha} +} -body { namespace which -variable test_ns_var::martha -} {::test_ns_var::martha} +} -result {::test_ns_var::martha} test var-6.1 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { namespace eval test_ns_var { @@ -348,6 +370,7 @@ test var-6.2 {Tcl_GlobalObjCmd, variable is qualified by a namespace name} { test_ns_var::p } {java} test var-6.3 {Tcl_GlobalObjCmd, variable named {} qualified by a namespace name} { + namespace eval ::test_ns_var::test_ns_nested {} set ::test_ns_var::test_ns_nested:: 24 apply {{} { global ::test_ns_var::test_ns_nested:: @@ -389,20 +412,26 @@ test var-7.2 {Tcl_VariableObjCmd, if new and no value, leave undefined} { } list [info exists test_ns_var::two] [catch {set test_ns_var::two} msg] $msg } {0 1 {can't read "test_ns_var::two": no such variable}} -test var-7.3 {Tcl_VariableObjCmd, "define" var already created above} { +test var-7.3 {Tcl_VariableObjCmd, "define" var already created above} -setup { + catch {namespace delete test_ns_var} + namespace eval test_ns_var {variable one 1} +} -body { namespace eval test_ns_var { variable two 2 } list [lsort [info vars test_ns_var::*]] \ [namespace eval test_ns_var {set two}] -} [list [lsort {::test_ns_var::two ::test_ns_var::one}] 2] -test var-7.4 {Tcl_VariableObjCmd, list of vars} { +} -result [list [lsort {::test_ns_var::two ::test_ns_var::one}] 2] +test var-7.4 {Tcl_VariableObjCmd, list of vars} -setup { + catch {namespace delete test_ns_var} + namespace eval test_ns_var {variable one 1; variable two 2} +} -body { namespace eval test_ns_var { variable three 3 four 4 } list [lsort [info vars test_ns_var::*]] \ [namespace eval test_ns_var {expr $three+$four}] -} [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7] +} -result [list [lsort {::test_ns_var::four ::test_ns_var::three ::test_ns_var::two ::test_ns_var::one}] 7] test var-7.5 {Tcl_VariableObjCmd, value for last var is optional} -setup { catch {unset a} catch {unset five} @@ -476,7 +505,9 @@ test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until na [lsort {::test_ns_var2::x ::test_ns_var2::z}] 0 0\ {1 {can't unset "test_ns_var2::z": no such variable}}\ {}] -test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} { +test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} -setup { + namespace eval test_ns_var { variable eight 8 } +} -body { namespace eval test_ns_var { proc p {} { variable eight @@ -484,14 +515,16 @@ test var-7.10 {Tcl_VariableObjCmd, variable cmd inside proc creates local link v } p } -} {8 eight} -test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} { +} -result {8 eight} +test var-7.11 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} -setup { + namespace eval test_ns_var { variable eight 8 } +} -body { proc p {} { ;# note this proc is at global :: scope variable test_ns_var::eight list [set eight] [info vars] } p -} {8 eight} +} -result {8 eight} test var-7.12 {Tcl_VariableObjCmd, variable cmd inside proc creates local link var} { namespace eval test_ns_var { variable {} {My name is empty} @@ -516,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 @@ -561,6 +594,22 @@ test var-8.2 {TclDeleteNamespaceVars, "unset" traces on ns delete are called wit list [namespace delete test_ns_var] $::info } -result {{} {::test_ns_var::v {} u}} +test var-8.3 {TclDeleteNamespaceVars, mem leak} -constraints memory -setup { + proc ::t {a i o} { + set $a 321 + } +} -body { + leaktest { + namespace eval n { + variable v 123 + trace variable v u ::t + } + namespace delete n + } +} -cleanup { + rename ::t {} +} -result 0 + test var-9.1 {behaviour of TclGet/SetVar simple get/set} -setup { catch {unset u} catch {unset v} @@ -742,7 +791,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. # @@ -774,7 +823,7 @@ test var-17.1 {TclArraySet [Bug 1669489]} -setup { test var-18.1 {array unset and unset traces: Bug 2939073} -setup { set already 0 - unset x + unset -nocomplain x } -body { array set x {e 1 i 1} trace add variable x unset {apply {args { @@ -896,9 +945,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) {} @@ -918,15 +964,45 @@ 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 doit {} { + interp create slave + slave eval { + proc doit script { + eval $script + set foo bar + } + doit {foreach foo baz {}} + } + interp delete slave + } +} -constraints memory -body { + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + doit + set tmp $end + set end [getbytes] + } + set leakedBytes [expr {$end - $tmp}] +} -cleanup { + array unset A + 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 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/winFCmd.test b/tests/winFCmd.test index a808c82..294745c 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,12 @@ proc cleanup {args} { } } -if {[testConstraint winOnly]} { +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 - } - } else { - testConstraint winOlderThan2000 1 + if {$major > 5} { + testConstraint winVista 1 + } elseif {$major == 5} { + testConstraint winXP 1 } } @@ -205,17 +200,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 +228,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 +441,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 +601,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 +699,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 +797,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 +835,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,7 +1050,7 @@ 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 { @@ -1350,13 +1328,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 +1345,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 +1356,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 +1367,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 +1378,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 +1389,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 +1401,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..53e46fc 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -34,14 +34,14 @@ testConstraint testexcept [llength [info commands testexcept]] 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 +74,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 +171,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] } { diff --git a/tests/zlib.test b/tests/zlib.test index b1d43fb..9f06eb1 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -132,6 +132,73 @@ test zlib-7.6 {zlib stream} zlib { $s close lappend result $data } {{} 69f34b6a abcdeEDCBA..} +test zlib-7.7 {zlib stream: Bug 25842c161} -constraints zlib -body { + set s [zlib stream deflate] + $s put {} +} -cleanup { + catch {$s close} +} -result "" +# Also causes Tk Bug 10f2e7872b +test zlib-7.8 {zlib stream: Bug b26e38a3e4} -constraints zlib -setup { + expr srand(12345) + set randdata {} + for {set i 0} {$i<6001} {incr i} { + append randdata [binary format c [expr {int(256*rand())}]] + } +} -body { + set strm [zlib stream compress] + for {set i 1} {$i<3000} {incr i} { + $strm put $randdata + } + $strm put -finalize $randdata + set data [$strm get] + list [string length $data] [string length [zlib decompress $data]] +} -cleanup { + catch {$strm close} + unset -nocomplain randdata data +} -result {120185 18003000} +test zlib-7.9 {zlib stream finalize (bug 25842c161)} -constraints zlib -setup { + set z1 [zlib stream gzip] + set z2 [zlib stream gzip] +} -body { + $z1 put ABCDEedbca.. + $z1 finalize + zlib gunzip [$z1 get] +} -cleanup { + $z1 close +} -result ABCDEedbca.. +test zlib-7.10 {zlib stream finalize (bug 25842c161)} -constraints zlib -setup { + set z2 [zlib stream gzip] +} -body { + $z2 put -finalize ABCDEedbca.. + zlib gunzip [$z2 get] +} -cleanup { + $z2 close +} -result ABCDEedbca.. +test zlib-7.11 {zlib stream put -finalize (bug 25842c161)} -constraints zlib -setup { + set c [zlib stream gzip] + set d [zlib stream gunzip] +} -body { + $c put abcdeEDCBA.. + $c finalize + $d put [$c get] + $d finalize + $d get +} -cleanup { + $c close + $d close +} -result abcdeEDCBA.. +test zlib-7.12 {zlib stream put; zlib stream finalize (bug 25842c161)} -constraints zlib -setup { + set c [zlib stream gzip] + set d [zlib stream gunzip] +} -body { + $c put -finalize abcdeEDCBA.. + $d put -finalize [$c get] + $d get +} -cleanup { + $c close + $d close +} -result abcdeEDCBA.. test zlib-8.1 {zlib transformation} -constraints zlib -setup { set file [makeFile {} test.gz] @@ -244,10 +311,11 @@ test zlib-8.8 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push compress $outSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary -buffering none - fconfigure $inSide -blocking 0 -translation binary + fconfigure $outSide -blocking 1 -translation binary -buffering none + fconfigure $inSide -blocking 1 -translation binary puts -nonewline $outSide $spdyHeaders chan pop $outSide + chan close $outSide set compressed [read $inSide] catch {zlib decompress $compressed} err opt list [string length [zlib compress $spdyHeaders]] \ @@ -262,11 +330,12 @@ test zlib-8.9 {transformation and fconfigure} -setup { set strm [zlib stream decompress] } -constraints zlib -body { zlib push compress $outSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary -buffering none - fconfigure $inSide -blocking 0 -translation binary + fconfigure $outSide -blocking 1 -translation binary -buffering none + fconfigure $inSide -blocking 1 -translation binary puts -nonewline $outSide $spdyHeaders set result [fconfigure $outSide -checksum] chan pop $outSide + chan close $outSide $strm put -dictionary $spdyDict [read $inSide] lappend result [string length $spdyHeaders] [string length [$strm get]] } -cleanup { @@ -278,10 +347,11 @@ test zlib-8.10 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints {zlib recentZlib} -body { zlib push deflate $outSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary -buffering none - fconfigure $inSide -blocking 0 -translation binary + fconfigure $outSide -blocking 1 -translation binary -buffering none + fconfigure $inSide -blocking 1 -translation binary puts -nonewline $outSide $spdyHeaders chan pop $outSide + chan close $outSide set compressed [read $inSide] catch { zlib inflate $compressed @@ -299,10 +369,11 @@ test zlib-8.11 {transformation and fconfigure} -setup { set strm [zlib stream inflate] } -constraints zlib -body { zlib push deflate $outSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary -buffering none - fconfigure $inSide -blocking 0 -translation binary + fconfigure $outSide -blocking 1 -translation binary -buffering none + fconfigure $inSide -blocking 1 -translation binary puts -nonewline $outSide $spdyHeaders chan pop $outSide + chan close $outSide $strm put -dictionary $spdyDict [read $inSide] list [string length $spdyHeaders] [string length [$strm get]] } -cleanup { @@ -316,7 +387,7 @@ test zlib-8.12 {transformation and fconfigure} -setup { } -constraints zlib -body { $strm put -dictionary $spdyDict -finalize $spdyHeaders zlib push decompress $inSide - fconfigure $outSide -blocking 0 -translation binary + fconfigure $outSide -blocking 1 -translation binary fconfigure $inSide -translation binary -dictionary $spdyDict puts -nonewline $outSide [$strm get] close $outSide @@ -333,7 +404,7 @@ test zlib-8.13 {transformation and fconfigure} -setup { } -constraints zlib -body { $strm put -dictionary $spdyDict -finalize $spdyHeaders zlib push decompress $inSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -translation binary + fconfigure $outSide -blocking 1 -translation binary fconfigure $inSide -translation binary puts -nonewline $outSide [$strm get] close $outSide @@ -350,7 +421,7 @@ test zlib-8.14 {transformation and fconfigure} -setup { } -constraints zlib -body { $strm put -finalize -dictionary $spdyDict $spdyHeaders zlib push inflate $inSide - fconfigure $outSide -blocking 0 -buffering none -translation binary + fconfigure $outSide -blocking 1 -buffering none -translation binary fconfigure $inSide -translation binary -dictionary $spdyDict puts -nonewline $outSide [$strm get] close $outSide @@ -366,7 +437,7 @@ test zlib-8.15 {transformation and fconfigure} -setup { } -constraints zlib -body { $strm put -finalize -dictionary $spdyDict $spdyHeaders zlib push inflate $inSide -dictionary $spdyDict - fconfigure $outSide -blocking 0 -buffering none -translation binary + fconfigure $outSide -blocking 1 -buffering none -translation binary fconfigure $inSide -translation binary puts -nonewline $outSide [$strm get] close $outSide @@ -395,6 +466,26 @@ test zlib-8.16 {Bug 3603553: buffer transfer with large writes} -setup { } -cleanup { removeFile $file } -result 57647 +test zlib-8.17 {Bug dd260aaf: fconfigure} -setup { + lassign [chan pipe] inSide outSide +} -constraints zlib -body { + zlib push inflate $inSide + zlib push deflate $outSide + list [chan configure $inSide -dictionary] [chan configure $outSide -dictionary] +} -cleanup { + catch {close $inSide} + catch {close $outSide} +} -result {{} {}} +test zlib-8.18 {Bug dd260aaf: fconfigure} -setup { + lassign [chan pipe] inSide outSide +} -constraints zlib -body { + zlib push inflate $inSide -dictionary "one two" + zlib push deflate $outSide -dictionary "one two" + list [chan configure $inSide -dictionary] [chan configure $outSide -dictionary] +} -cleanup { + catch {close $inSide} + catch {close $outSide} +} -result {{one two} {one two}} test zlib-9.1 "check fcopy with push" -constraints zlib -setup { set sfile [makeFile {} testsrc.gz] @@ -417,6 +508,7 @@ test zlib-9.2 "socket fcopy with push" -constraints zlib -setup { chan configure $c -translation binary -buffering none -blocking 0 puts -nonewline $c [zlib gzip [string repeat a 81920]] close $c + set ::total -1 }}} 0] set file [makeFile {} test.gz] } -body { @@ -424,7 +516,10 @@ test zlib-9.2 "socket fcopy with push" -constraints zlib -setup { set sin [socket $addr $port] chan configure $sin -translation binary zlib push gunzip $sin - update + after 1000 {set ::total timeout} + vwait ::total + after cancel {set ::total timeout} + if {$::total != -1} {error "unexpected value $::total of ::total"} set total [fcopy $sin [set fout [open $file wb]]] close $sin close $fout @@ -869,6 +964,47 @@ test zlib-11.3 {Bug 3595576 variant} -setup { } -cleanup { removeFile $file } -returnCodes error -result {can't set "noSuchNs::foo": parent namespace doesn't exist} + +test zlib-12.1 {Tk Bug 9eb55debc5} -constraints zlib -setup { + set stream [zlib stream compress] +} -body { + for {set opts {};set y 0} {$y < 60} {incr y} { + for {set line {};set x 0} {$x < 100} {incr x} { + append line [binary format ccc $x $y 128] + } + if {$y == 59} { + set opts -finalize + } + $stream put {*}$opts $line + } + set data [$stream get] + list [string length $data] [string length [zlib decompress $data]] +} -cleanup { + $stream close +} -result {12026 18000} +test zlib-12.2 {Patrick Dunnigan's issue} -constraints zlib -setup { + set filesrc [makeFile {} test.input] + set filedst [makeFile {} test.output] + set f [open $filesrc "wb"] + for {set i 0} {$i < 10000} {incr i} { + puts -nonewline $f "x" + } + close $f +} -body { + set fin [open $filesrc "rb"] + set fout [open $filedst "wb"] + set header [dict create filename "test.input" time 0] + try { + fcopy $fin [zlib push gzip $fout -header $header] + } finally { + close $fin + close $fout + } + file size $filedst +} -cleanup { + removeFile $filesrc + removeFile $filedst +} -result 4152 ::tcltest::cleanupTests return |