diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/assemble.test | 3 | ||||
| -rw-r--r-- | tests/binary.test | 103 | ||||
| -rw-r--r-- | tests/cmdIL.test | 9 | ||||
| -rw-r--r-- | tests/compile.test | 100 | ||||
| -rw-r--r-- | tests/coroutine.test | 120 | ||||
| -rw-r--r-- | tests/dict.test | 93 | ||||
| -rw-r--r-- | tests/env.test | 29 | ||||
| -rw-r--r-- | tests/error.test | 162 | ||||
| -rw-r--r-- | tests/for.test | 376 | ||||
| -rw-r--r-- | tests/foreach.test | 11 | ||||
| -rw-r--r-- | tests/http.test | 4 | ||||
| -rw-r--r-- | tests/httpd | 2 | ||||
| -rw-r--r-- | tests/info.test | 434 | ||||
| -rw-r--r-- | tests/interp.test | 14 | ||||
| -rw-r--r-- | tests/load.test | 6 | ||||
| -rw-r--r-- | tests/misc.test | 7 | ||||
| -rw-r--r-- | tests/namespace.test | 9 | ||||
| -rw-r--r-- | tests/oo.test | 135 | ||||
| -rw-r--r-- | tests/ooNext2.test | 2 | ||||
| -rw-r--r-- | tests/parse.test | 27 | ||||
| -rw-r--r-- | tests/reg.test | 3 | ||||
| -rw-r--r-- | tests/regexp.test | 4 | ||||
| -rw-r--r-- | tests/rename.test | 7 | ||||
| -rw-r--r-- | tests/safe.test | 80 | ||||
| -rw-r--r-- | tests/scan.test | 17 | ||||
| -rw-r--r-- | tests/socket.test | 28 | ||||
| -rw-r--r-- | tests/source.test | 10 | ||||
| -rw-r--r-- | tests/subst.test | 4 | ||||
| -rw-r--r-- | tests/trace.test | 7 | ||||
| -rw-r--r-- | tests/unixForkEvent.test | 45 | ||||
| -rw-r--r-- | tests/upvar.test | 43 | ||||
| -rw-r--r-- | tests/utf.test | 4 | ||||
| -rw-r--r-- | tests/var.test | 16 | ||||
| -rw-r--r-- | tests/zlib.test | 30 |
34 files changed, 1860 insertions, 84 deletions
diff --git a/tests/assemble.test b/tests/assemble.test index 942b763..d424c86 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -175,8 +175,7 @@ test assemble-4.1 {syntax error} { -match glob -result {1 {extra characters after close-brace} {extra characters after close-brace while executing -"{}extra - " +"{}e" ("assemble" body, line 2)*}} } test assemble-4.2 {null command} { diff --git a/tests/binary.test b/tests/binary.test index 4393245..40b1315 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2499,6 +2499,34 @@ test binary-71.9 {binary decode hex} -body { test binary-71.10 {binary decode hex} -body { string length [binary decode hex " "] } -result 0 +test binary-71.11 {binary decode hex: Bug b98fa55285} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c26\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {29 38} +test binary-71.12 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} +test binary-71.13 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} +test binary-71.14 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} test binary-72.1 {binary encode base64} -body { binary encode base64 @@ -2677,105 +2705,116 @@ test binary-74.1 {binary encode uuencode} -body { } -returnCodes error -match glob -result "wrong # args: *" test binary-74.2 {binary encode uuencode} -body { binary encode uuencode abc -} -result {86)C} +} -result {#86)C +} test binary-74.3 {binary encode uuencode} -body { binary encode uuencode {} } -result {} test binary-74.4 {binary encode uuencode} -body { binary encode uuencode [string repeat abc 20] -} -result [string repeat 86)C 20] +} -result "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n" test binary-74.5 {binary encode uuencode} -body { binary encode uuencode \0\1\2\3\4\0\1\2\3 -} -result "``\$\"`P0``0(#" +} -result ")``\$\"`P0``0(#\n" test binary-74.6 {binary encode uuencode} -body { binary encode uuencode \0 -} -result {````} +} -result {!`` +} test binary-74.7 {binary encode uuencode} -body { binary encode uuencode \0\0 -} -result {````} +} -result "\"``` +" test binary-74.8 {binary encode uuencode} -body { binary encode uuencode \0\0\0 -} -result {````} +} -result {#```` +} test binary-74.9 {binary encode uuencode} -body { binary encode uuencode \0\0\0\0 -} -result {````````} -test binary-74.10 {binary encode uuencode} -body { - binary encode uuencode -maxlen 0 -wrapchar | abcabcabc -} -result {86)C86)C86)C} -test binary-74.11 {binary encode uuencode} -body { - binary encode uuencode -maxlen 1 -wrapchar | abcabcabc -} -result {8|6|)|C|8|6|)|C|8|6|)|C} +} -result {$`````` +} +test binary-74.10 {binary encode uuencode} -returnCodes error -body { + binary encode uuencode -foo 30 abcabcabc +} -result {bad option "-foo": must be -maxlen or -wrapchar} +test binary-74.11 {binary encode uuencode} -returnCodes error -body { + binary encode uuencode -maxlen 1 abcabcabc +} -result {line length out of range} +test binary-74.12 {binary encode uuencode} -body { + binary encode uuencode -maxlen 3 -wrapchar | abcabcabc +} -result {!80|!8@|!8P|!80|!8@|!8P|!80|!8@|!8P|} test binary-75.1 {binary decode uuencode} -body { binary decode uuencode } -returnCodes error -match glob -result "wrong # args: *" test binary-75.2 {binary decode uuencode} -body { - binary decode uuencode 86)C + binary decode uuencode "#86)C\n" } -result {abc} test binary-75.3 {binary decode uuencode} -body { binary decode uuencode {} } -result {} +test binary-75.3.1 {binary decode uuencode} -body { + binary decode uuencode `\n +} -result {} test binary-75.4 {binary decode uuencode} -body { - binary decode uuencode [string repeat "86)C" 20] + binary decode uuencode "M[string repeat 86)C 15]\n/[string repeat 86)C 5]\n" } -result [string repeat abc 20] test binary-75.5 {binary decode uuencode} -body { - binary decode uuencode "``\$\"`P0``0(#" + binary decode uuencode ")``\$\"`P0``0(#" } -result "\0\1\2\3\4\0\1\2\3" test binary-75.6 {binary decode uuencode} -body { - string length [binary decode uuencode {`}] + string length [binary decode uuencode "`\n"] } -result 0 test binary-75.7 {binary decode uuencode} -body { - string length [binary decode uuencode {``}] + string length [binary decode uuencode "!`\n"] } -result 1 test binary-75.8 {binary decode uuencode} -body { - string length [binary decode uuencode {```}] + string length [binary decode uuencode "\"``\n"] } -result 2 test binary-75.9 {binary decode uuencode} -body { - string length [binary decode uuencode {````}] + string length [binary decode uuencode "#```\n"] } -result 3 test binary-75.10 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n[string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\n>[string repeat 86)C 10]" binary decode uuencode $s } -result [string repeat abc 20] test binary-75.11 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n [string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\n\t>\t[string repeat 86)C 10]\r" binary decode uuencode $s } -result [string repeat abc 20] test binary-75.12 {binary decode uuencode} -body { binary decode uuencode -strict "|86)C" } -returnCodes error -match glob -result {invalid uuencode character "|" at position 0} test binary-75.13 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]|[string repeat 86)C 10]" + set s ">[string repeat 86)C 10]|[string repeat 86)C 10]" binary decode uuencode -strict $s -} -returnCodes error -match glob -result {invalid uuencode character "|" at position 40} +} -returnCodes error -match glob -result {invalid uuencode character "|" at position 41} test binary-75.14 {binary decode uuencode} -body { - set s "[string repeat 86)C 10]\n [string repeat 86)C 10]" + set s ">[string repeat 86)C 10]\na[string repeat 86)C 10]" binary decode uuencode -strict $s } -returnCodes error -match glob -result {invalid uuencode character *} test binary-75.20 {binary decode uuencode} -body { - set r [binary decode uuencode 8] + set r [binary decode uuencode " 8"] list [string length $r] $r } -result {0 {}} test binary-75.21 {binary decode uuencode} -body { - set r [binary decode uuencode 86] + set r [binary decode uuencode "!86"] list [string length $r] $r } -result {1 a} test binary-75.22 {binary decode uuencode} -body { - set r [binary decode uuencode 86)] + set r [binary decode uuencode "\"86)"] list [string length $r] $r } -result {2 ab} test binary-75.23 {binary decode uuencode} -body { - set r [binary decode uuencode 86)C] + set r [binary decode uuencode "#86)C"] list [string length $r] $r } -result {3 abc} test binary-75.24 {binary decode uuencode} -body { - set s "04)\# " + set s "#04)\# " binary decode uuencode $s } -result ABC test binary-75.25 {binary decode uuencode} -body { - set s "04)\#z" + set s "#04)\#z" binary decode uuencode $s -} -returnCodes error -match glob -result {invalid uuencode character "z" at position 4} +} -returnCodes error -match glob -result {invalid uuencode character "z" at position 5} test binary-75.26 {binary decode uuencode} -body { string length [binary decode uuencode " "] } -result 0 diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 721773f..23a5f96 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -417,6 +417,15 @@ test cmdIL-4.34 {SortCompare procedure, -ascii option with -nocase option} { test cmdIL-4.35 {SortCompare procedure, -ascii option with -nocase option} { lsort -ascii -nocase {d E c B a D35 d300 100 20} } {100 20 a B c d d300 D35 E} +test cmdIL-4.36 {SortCompare procedure, UTF-8 with -nocase option} { + scan [lsort -ascii -nocase [list \u101 \u100]] %c%c%c +} {257 32 256} +test cmdIL-4.37 {SortCompare procedure, UTF-8 with -nocase option} { + scan [lsort -ascii -nocase [list a\u0000a a]] %c%c%c%c%c +} {97 32 97 0 97} +test cmdIL-4.38 {SortCompare procedure, UTF-8 with -nocase option} { + scan [lsort -ascii -nocase [list a a\u0000a]] %c%c%c%c%c +} {97 32 97 0 97} test cmdIL-5.1 {lsort with list style index} { lsort -ascii -decreasing -index {0 1} { diff --git a/tests/compile.test b/tests/compile.test index d276460..07538d5 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -167,6 +167,36 @@ test compile-3.6 {TclCompileCatchCmd: error in storing result [Bug 3098302]} {*} -cleanup {namespace delete catchtest} } +test compile-3.7 {TclCompileCatchCmd: error in storing options [Bug 3098302]} {*}{ + -setup { + namespace eval catchtest { + variable options1 {} + } + trace add variable catchtest::options1 write catchtest::failtrace + proc catchtest::failtrace {n1 n2 op} { + return -code error "trace on $n1 fails by request" + } + } + -body { + proc catchtest::x {} { + variable options1 + set count 0 + for {set i 0} {$i < 10} {incr i} { + set status2 [catch { + set status1 [catch { + return -code error -level 0 "original failure" + } result1 options1] + } result2 options2] + incr count + } + list $count $result2 + } + catchtest::x + } + -result {10 {can't set "options1": trace on options1 fails by request}} + -cleanup {namespace delete catchtest} +} + test compile-4.1 {TclCompileForCmd: command substituted test expression} { set i 0 set j 0 @@ -707,6 +737,76 @@ test compile-18.19 {disassembler - basics} -setup { } -cleanup { foo destroy } -match glob -result * + +test compile-19.0 {Bug 3614102: reset stack housekeeping} -body { + # This will panic in a --enable-symbols=compile build, unless bug is fixed. + apply {{} {list [if 1]}} +} -returnCodes error -match glob -result * + +test compile-20.1 {ensure there are no infinite loops in optimizing} { + tcl::unsupported::disassemble script { + while 1 { + return -code continue -level 0 + } + } + return +} {} +test compile-20.2 {ensure there are no infinite loops in optimizing} { + tcl::unsupported::disassemble script { + while 1 { + while 1 { + return -code break -level 0 + } + } + } + return +} {} + +test compile-21.1 {stack balance management} { + apply {{} { + set result {} + while 1 { + lappend result a + lappend result [list b [break]] + lappend result c + } + return $result + }} +} a +test compile-21.2 {stack balance management} { + apply {{} { + set result {} + while {[incr i] <= 10} { + lappend result $i + lappend result [list b [continue] c] + lappend result c + } + return $result + }} +} {1 2 3 4 5 6 7 8 9 10} +test compile-21.3 {stack balance management} { + apply {args { + set result {} + while 1 { + lappend result a + lappend result [concat {*}$args [break]] + lappend result c + } + return $result + }} P Q R S T +} a +test compile-21.4 {stack balance management} { + apply {args { + set result {} + while {[incr i] <= 10} { + lappend result $i + lappend result [concat {*}$args [continue] c] + lappend result c + } + return $result + }} P Q R S T +} {1 2 3 4 5 6 7 8 9 10} + # TODO sometime - check that bytecode from tbcload is *not* disassembled. # cleanup diff --git a/tests/coroutine.test b/tests/coroutine.test index 1d9040b..05b58c9 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -1,4 +1,4 @@ -# Commands covered: coroutine, yield, [info coroutine] +# Commands covered: coroutine, yield, yieldto, [info coroutine] # # This file contains a collection of tests for experimental commands that are # found in ::tcl::unsupported. The tests will migrate to normal test files @@ -342,6 +342,9 @@ test coroutine-3.6 {info frame, bug #2910094} -setup { rename stack {} rename a {} } -result {} +test coroutine-3.7 {bug 0b874c344d} { + dict get [coroutine X coroutine Y info frame 0] cmd +} {coroutine X coroutine Y info frame 0} test coroutine-4.1 {bug #2093188} -setup { proc foo {} { @@ -609,6 +612,121 @@ test coroutine-7.3 {yielding between coroutines} -body { } -cleanup { catch {rename juggler ""} } -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}} +test coroutine-7.4 {Bug 8ff0cb9fe1} -setup { + proc foo {a b} {catch yield; return 1} +} -cleanup { + rename foo {} +} -body { + coroutine demo lsort -command foo {a b} +} -result {b a} +test coroutine-7.5 {return codes} { + set result {} + foreach code {0 1 2 3 4 5} { + lappend result [catch {coroutine demo return -level 0 -code $code}] + } + set result +} {0 1 2 3 4 5} +test coroutine-7.6 {Early yield crashes} { + proc foo args {} + trace add execution foo enter {catch yield} + coroutine demo foo + rename foo {} +} {} +test coroutine-7.7 {Bug 2486550} -setup { + interp hide {} yield +} -body { + coroutine demo interp invokehidden {} yield ok +} -cleanup { + demo + interp expose {} yield +} -result ok +test coroutine-7.8 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + lappend ::result a + yield OUT + lappend ::result b + yieldto ::return -level 0 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + namespace delete cotest + namespace eval cotest {} + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.9 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + set y ::yieldto + lappend ::result a + yield OUT + lappend ::result b + $y ::return -level 0 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + namespace delete cotest + namespace eval cotest {} + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.10 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + lappend ::result a + yield OUT + lappend ::result b + yieldto ::return -level 0 -cotest [namespace delete ::cotest] 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} +test coroutine-7.11 {yieldto context nuke: Bug a90d9331bc} -setup { + namespace eval cotest {} + set ::result "" +} -body { + proc cotest::body {} { + set y ::yieldto + lappend ::result a + yield OUT + lappend ::result b + $y ::return -level 0 -cotest [namespace delete ::cotest] 123 + lappend ::result c + return + } + lappend ::result [coroutine cotest cotest::body] + lappend ::result [cotest] + cotest + return $result +} -returnCodes error -cleanup { + catch {namespace delete ::cotest} + catch {rename cotest ""} +} -result {yieldto called in deleted namespace} + # cleanup unset lambda diff --git a/tests/dict.test b/tests/dict.test index 72a336c..a583de8 100644 --- a/tests/dict.test +++ b/tests/dict.test @@ -668,6 +668,24 @@ test dict-14.20 {dict for stack space compilation: bug 1903325} { concat "c=$y,$args" }} {} 1 2 3 } {c=1,2 3} +test dict-14.21 {compiled dict for and break} { + apply {{} { + dict for {a b} {c d e f} { + lappend result $a,$b + break + } + return $result + }} +} c,d +test dict-14.22 {dict for and exception range depths: Bug 3614382} { + apply {{} { + dict for {a b} {c d} { + dict for {e f} {g h} { + return 5 + } + } + }} +} 5 # There's probably a lot more tests to add here. Really ought to use a # coverage tool for this job... @@ -1586,7 +1604,7 @@ test dict-23.1 {dict compilation crash: Bug 3487626} { } }} [linenumber]}} } 5 -test dict-23.2 {dict compilation crash: Bug 3487626} knownBug { +test dict-23.2 {dict compilation crash: Bug 3487626} { # Something isn't quite right in line number and continuation line # tracking; at time of writing, this test produces 7, not 5, which # indicates that the extra newlines in the non-script argument are @@ -1820,7 +1838,7 @@ test dict-24.20.1 {dict compilation crash: 'dict for' bug 3487626} { } }} [linenumber]}} } 5 -test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} knownBug { +test dict-24.21 {dict compilation crash: 'dict for' bug 3487626} { apply {{} {apply {n { set e {} set k {} @@ -1847,6 +1865,77 @@ j } }} [linenumber]}} } 5 +test dict-23.3 {CompileWord OBOE} { + # segfault when buggy + apply {{} {tcl::dict::lappend foo bar \ + [format baz]}} +} {bar baz} +test dict-23.4 {CompileWord OBOE} { + apply {n { + dict set foo {*}{ + } [return [incr n -[linenumber]]] val + }} [linenumber] +} 1 +test dict-23.5 {CompileWord OBOE} { + # segfault when buggy + apply {{} {tcl::dict::incr foo \ + [format bar]}} +} {bar 1} +test dict-23.6 {CompileWord OBOE} { + apply {n { + dict get {a b} {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} 1 +test dict-23.7 {CompileWord OBOE} { + apply {n { + dict for {a b} [return [incr n -[linenumber]]] {*}{ + } {} + }} [linenumber] +} 2 +test dict-23.8 {CompileWord OBOE} { + apply {n { + dict update foo {*}{ + } [return [incr n -[linenumber]]] x {} + }} [linenumber] +} 1 +test dict-23.9 {CompileWord OBOE} { + apply {n { + dict exists {} {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} 1 +test dict-23.10 {CompileWord OBOE} { + apply {n { + dict with foo {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.11 {CompileWord OBOE} { + apply {n { + dict with ::foo {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.12 {CompileWord OBOE} { + apply {n { + dict with {*}{ + } [return [incr n -[linenumber]]] {} + }} [linenumber] +} 1 +test dict-23.13 {CompileWord OBOE} { + apply {n { + dict with {*}{ + } [return [incr n -[linenumber]]] {bar} + }} [linenumber] +} 1 +test dict-23.14 {CompileWord OBOE} { + apply {n { + dict with foo {*}{ + } [return [incr n -[linenumber]]] {bar} + }} [linenumber] +} 1 + rename linenumber {} test dict-24.22 {dict map results (non-compiled)} { dict map {k v} [dict map {k v} {a 1 b 2 c 3 d 4} { list $v $k }] { diff --git a/tests/env.test b/tests/env.test index e75d517..83d99e0 100644 --- a/tests/env.test +++ b/tests/env.test @@ -89,7 +89,7 @@ set printenvScript [makeFile { SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING __CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM - CommonProgramFiles ProgramFiles + CommonProgramFiles ProgramFiles CommonProgramW6432 ProgramW6432 } { lrem names $name } @@ -121,7 +121,7 @@ foreach name [array names env] { SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING SECURITYSESSIONID LANG WINDIR TERM - CommonProgramFiles ProgramFiles + CONNOMPROGRAMFILES PROGRAMFILES COMMONPROGRAMW6432 PROGRAMW6432 }} { unset env($name) } @@ -218,8 +218,8 @@ test env-4.5 {unsetting international environment variables} -setup { unset env(\ua7) getenv } -constraints {exec} -cleanup { - encoding system $sysenc unset env(\ub6) + encoding system $sysenc } -result {\u00b6=\u00a7} test env-5.0 {corner cases - set a value, it should exist} -body { @@ -291,6 +291,29 @@ test env-6.1 {corner cases - add lots of env variables} {} { expr {[array size env] - $size} } 100 +test env-7.1 {[219226]: whole env array should not be unset by read} { + set n [array size env] + set s [array startsearch env] + while {[array anymore env $s]} { + array nextelement env $s + incr n -1 + } + array donesearch env $s + return $n +} 0 +test env-7.2 {[219226]: links to env elements should not be removed by read} { + apply {{} { + set ::env(test7_2) ok + upvar env(test7_2) elem + set ::env(PATH) + try { + return $elem + } finally { + unset ::env(test7_2) + } + }} +} ok + # Restore the environment variables at the end of the test. foreach name [array names env] { diff --git a/tests/error.test b/tests/error.test index 97bcc0a..0de644c 100644 --- a/tests/error.test +++ b/tests/error.test @@ -17,6 +17,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } testConstraint memory [llength [info commands memory]] +customMatch pairwise {apply {{a b} { + string equal [lindex $b 0] [lindex $b 1] +}}} namespace eval ::tcl::test::error { if {[testConstraint memory]} { proc getbytes {} { @@ -179,6 +182,16 @@ test error-4.7 {errorstack via options dict } -body { catch {f 12} m d dict get $d -errorstack } -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1} +test error-4.8 {errorstack from exec traces} -body { + proc foo args {} + proc goo {} foo + trace add execution foo enter {error bar;#} + catch goo m d + dict get $d -errorstack +} -cleanup { + rename goo {}; rename foo {} + unset -nocomplain m d +} -result {INNER {error bar} CALL goo UP 1} # Errors in error command itself @@ -314,6 +327,12 @@ test error-8.8 {throw syntax checks} -returnCodes error -body { test error-8.9 {throw syntax checks} -returnCodes error -body { throw {} foo } -result {type must be non-empty list} +test error-8.10 {Bug 33b7abb8a2: throw stack usage} -returnCodes error -body { + apply {code {throw $code foo}} {} +} -result {type must be non-empty list} +test error-8.11 {Bug 7174354ecb: throw error message} -returnCodes error -body { + throw {not {}a list} x[]y +} -result {list element in braces followed by "a" instead of space} # simple try tests: body completes with code ok @@ -601,21 +620,21 @@ test error-16.7 {try with variable assignment and propagation #2} { } list $em [dict get $opts -errorcode] } {bar FOO} -test error-16.8 {exception chaining (try=ok, handler=error)} { +test error-16.8 {exception chaining (try=ok, handler=error)} -body { #FIXME is the intent of this test correct? catch { try { list a b c } on ok {em opts} { throw BAR baz } } tryem tryopts - string equal $opts [dict get $tryopts -during] -} {1} -test error-16.9 {exception chaining (try=error, handler=error)} { + list $opts [dict get $tryopts -during] +} -match pairwise -result equal +test error-16.9 {exception chaining (try=error, handler=error)} -body { # The exception off the handler should chain to the exception off the # try-body (using the -during option) catch { try { throw FOO bar } trap {} {em opts} { throw BAR baz } } tryem tryopts - string equal $opts [dict get $tryopts -during] -} {1} + list $opts [dict get $tryopts -during] +} -match pairwise -result equal test error-16.10 {no exception chaining when handler is successful} { catch { try { throw FOO bar } trap {} {em opts} { list d e f } @@ -628,6 +647,131 @@ test error-16.11 {no exception chaining when handler is a non-error exception} { } tryem tryopts dict exists $tryopts -during } {0} +test error-16.12 {compiled try with successfully executed handler} { + apply {{} { + try { throw FOO bar } trap FOO {} { list a b c } + }} +} {a b c} +test error-16.13 {compiled try with exception (error) in handler} -body { + apply {{} { + try { throw FOO bar } trap FOO {} { throw BAR foo } + }} +} -returnCodes error -result {foo} +test error-16.14 {compiled try with exception (return) in handler} -body { + apply {{} { + list [catch { + try { throw FOO bar } trap FOO {} { return BAR } + } msg] $msg + }} +} -result {2 BAR} +test error-16.15 {compiled try with exception (break) in handler} { + apply {{} { + for { set i 5 } { $i < 10 } { incr i } { + try { throw FOO bar } trap FOO {} { break } + } + return $i + }} +} {5} +test error-16.16 {compiled try with exception (continue) in handler} { + apply {{} { + for { set i 5 } { $i < 10 } { incr i } { + try { throw FOO bar } trap FOO {} { continue } + incr i 20 + } + return $i + }} +} {10} +test error-16.17 {compiled try with variable assignment and propagation #1} { + # Ensure that the handler variables preserve the exception off the + # try-body, and are not modified by the exception off the handler + apply {{} { + catch { + try { throw FOO bar } trap FOO {em} { throw BAR baz } + } + return $em + }} +} {bar} +test error-16.18 {compiled try with variable assignment and propagation #2} { + apply {{} { + catch { + try { throw FOO bar } trap FOO {em opts} { throw BAR baz } + } + list $em [dict get $opts -errorcode] + }} +} {bar FOO} +test error-16.19 {compiled try exception chaining (try=ok, handler=error)} -body { + #FIXME is the intent of this test correct? + apply {{} { + catch { + try { list a b c } on ok {em opts} { throw BAR baz } + } tryem tryopts + list $opts [dict get $tryopts -during] + }} +} -match pairwise -result equal +test error-16.20 {compiled try exception chaining (try=error, handler=error)} -body { + # The exception off the handler should chain to the exception off the + # try-body (using the -during option) + apply {{} { + catch { + try { throw FOO bar } trap {} {em opts} { throw BAR baz } + } tryem tryopts + list $opts [dict get $tryopts -during] + }} +} -match pairwise -result equal +test error-16.21 {compiled try exception chaining (try=error, finally=error)} { + # The exception off the handler should chain to the exception off the + # try-body (using the -during option) + apply {{} { + catch { + try { throw FOO bar } finally { throw BAR baz } + } tryem tryopts + dict get $tryopts -during -errorcode + }} +} FOO +test error-16.22 {compiled try: no exception chaining when handler is successful} { + apply {{} { + catch { + try { throw FOO bar } trap {} {em opts} { list d e f } + } tryem tryopts + dict exists $tryopts -during + }} +} {0} +test error-16.23 {compiled try: no exception chaining when handler is a non-error exception} { + apply {{} { + catch { + try { throw FOO bar } trap {} {em opts} { break } + } tryem tryopts + dict exists $tryopts -during + }} +} {0} +test error-16.24 {compiled try exception chaining (try=ok, handler=error, finally=error)} -body { + apply {{} { + catch { + try { + list a b c + } on ok {em opts} { + throw BAR baz + } finally { + throw DING dong + } + } tryem tryopts + list $opts [dict get $tryopts -during -during] + }} +} -match pairwise -result equal +test error-16.25 {compiled try exception chaining (all errors)} -body { + apply {{} { + catch { + try { + throw FOO bar + } on error {em opts} { + throw BAR baz + } finally { + throw DING dong + } + } tryem tryopts + list $opts [dict get $tryopts -during -during] + }} +} -match pairwise -result equal # try tests - finally @@ -709,15 +853,15 @@ test error-18.5 {exception in finally doesn't affect variable assignment} { } list $em [dict get $opts -errorcode] } {bar FOO} -test error-18.6 {exception chaining in finally (try=ok)} { +test error-18.6 {exception chaining in finally (try=ok)} -body { catch { list a b c } em expopts catch { try { list a b c } finally { throw BAR foo } } em opts - string equal $expopts [dict get $opts -during] -} {1} + list $expopts [dict get $opts -during] +} -match pairwise -result equal test error-18.7 {exception chaining in finally (try=error)} { catch { try { throw FOO bar } finally { throw BAR baz } diff --git a/tests/for.test b/tests/for.test index ff4dc0e..8abd270 100644 --- a/tests/for.test +++ b/tests/for.test @@ -14,6 +14,12 @@ if {[lsearch [namespace children] ::tcltest] == -1} { namespace import -force ::tcltest::* } +# Used for constraining memory leak tests +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc meminfo {} {lindex [split [memory info] "\n"] 3 3} +} + # Basic "for" operation. test for-1.1 {TclCompileForCmd: missing initial command} { @@ -345,7 +351,6 @@ proc formatMail {} { 64 { UNIX (Solaris 2.* and SunOS, other systems soon to follow). Easy to install} \ 65 { binary packages are now for sale at the Sun Labs Tcl/Tk Shop. Check it out!} \ } - set result "" set NL " " @@ -365,7 +370,6 @@ proc formatMail {} { } else { set break 1 } - set xmailer 0 set inheaders 1 set last [array size lines] @@ -386,9 +390,7 @@ proc formatMail {} { set limit 55 } else { set limit 55 - # Decide whether or not to break the body line - if {$plen > 0} { if {[string first {> } $line] == 0} { # This is quoted text from previous message, don't reformat @@ -431,7 +433,7 @@ proc formatMail {} { set climit [expr $limit-1] set cutoff 50 set continuation 0 - + while {[string length $line] > $limit} { for {set c [expr $limit-1]} {$c >= $cutoff} {incr c -1} { set char [string index $line $c] @@ -824,7 +826,369 @@ test for-6.18 {Tcl_ForObjCmd: for command result} { 1 {invoked "continue" outside of a loop} \ ] - +test for-7.1 {Bug 3614226: ensure that break cleans up the stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [break] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.2 {Bug 3614226: ensure that continue cleans up the stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [continue] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.3 {Bug 3614226: ensure that break cleans up the expansion stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[break] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.4 {Bug 3614226: ensure that continue cleans up the expansion stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[continue] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.5 {Bug 3614226: ensure that break cleans up the combination of main and expansion stack} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[break] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.6 {Bug 3614226: ensure that continue cleans up the combination of main and expansion stack} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[continue] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.7 {Bug 3614226: ensure that break only cleans up the right amount} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[break] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.8 {Bug 3614226: ensure that continue only cleans up the right amount} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[continue] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.9 {Bug 3614226: ensure that break from invoked command cleans up the stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [apply {{} {return -code break}}] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.10 {Bug 3614226: ensure that continue from invoked command cleans up the stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [apply {{} {return -code continue}}] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.11 {Bug 3614226: ensure that break from invoked command cleans up the expansion stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[apply {{} {return -code break}}] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.12 {Bug 3614226: ensure that continue from invoked command cleans up the expansion stack} memory { + apply {{} { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[apply {{} { + return -code continue + }}] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.13 {Bug 3614226: ensure that break from invoked command cleans up the combination of main and expansion stack} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code break + }}] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.14 {Bug 3614226: ensure that continue from invoked command cleans up the combination of main and expansion stack} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code continue + }}] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.15 {Bug 3614226: ensure that break from invoked command only cleans up the right amount} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code break + }}] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.16 {Bug 3614226: ensure that continue from invoked command only cleans up the right amount} memory { + apply {{} { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[apply {{} { + return -code continue + }}] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} +} 0 +test for-7.17 {Bug 3614226: ensure that break from expanded command cleans up the stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [{*}$op] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.18 {Bug 3614226: ensure that continue from expanded command cleans up the stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {$x < 5} {incr x} { + list a b c [{*}$op] d e f + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 +test for-7.19 {Bug 3614226: ensure that break from expanded command cleans up the expansion stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[{*}$op] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.20 {Bug 3614226: ensure that continue from expanded command cleans up the expansion stack} memory { + apply {op { + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts {*}[puts a b c {*}[{*}$op] d e f] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 +test for-7.21 {Bug 3614226: ensure that break from expanded command cleans up the combination of main and expansion stack} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.22 {Bug 3614226: ensure that continue from expanded command cleans up the combination of main and expansion stack} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + } + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 +test for-7.23 {Bug 3614226: ensure that break from expanded command only cleans up the right amount} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code break} +} 0 +test for-7.24 {Bug 3614226: ensure that continue from expanded command only cleans up the right amount} memory { + apply {op { + set l [lrepeat 50 p q r] + # Can't use [memtest]; must be careful when we change stack frames + set end [meminfo] + for {set i 0} {$i < 5} {incr i} { + unset -nocomplain {*}[for {set x 0} {[incr x]<50} {} { + puts [puts {*}$l {*}[puts a b c {*}$l {*}[{*}$op] d e f]] + }] + set tmp $end + set end [meminfo] + } + expr {$end - $tmp} + }} {return -level 0 -code continue} +} 0 + # cleanup ::tcltest::cleanupTests return + +# Local Variables: +# mode: tcl +# End: diff --git a/tests/foreach.test b/tests/foreach.test index 6c69b29..6fd5476 100644 --- a/tests/foreach.test +++ b/tests/foreach.test @@ -254,6 +254,17 @@ test foreach-9.1 {compiled empty var list} { list [catch { foo } msg] $msg } {1 {foreach varlist is empty}} +test foreach-9.2 {line numbers} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + foreach x y {*}{ + } {return [incr n -[linenumber]]} + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 + test foreach-10.1 {foreach: [Bug 1671087]} -setup { proc demo {} { set vals {1 2 3 4} diff --git a/tests/http.test b/tests/http.test index 7d439b1..a52cfb1 100644 --- a/tests/http.test +++ b/tests/http.test @@ -119,7 +119,7 @@ test http-3.2 {http::geturl} -returnCodes error -body { http::geturl http:junk } -result {Unsupported URL: http:junk} set url //[info hostname]:$port -set badurl //[info hostname]:6666 +set badurl //[info hostname]:[expr $port+1] test http-3.3 {http::geturl} -body { set token [http::geturl $url] http::data $token @@ -131,7 +131,7 @@ test http-3.3 {http::geturl} -body { </body></html>" 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 fullurl HTTP://user:pass@[info hostname]:$port/a/b/c set binurl //[info hostname]:$port/binary set posturl //[info hostname]:$port/post set badposturl //[info hostname]:$port/droppost diff --git a/tests/httpd b/tests/httpd index f810797..232e80a 100644 --- a/tests/httpd +++ b/tests/httpd @@ -40,7 +40,7 @@ proc httpdAccept {newsock ipaddr port} { fconfigure $newsock -blocking 0 -translation {auto crlf} httpd_log $newsock Connect $ipaddr $port set data(ipaddr) $ipaddr - fileevent $newsock readable [list httpdRead $newsock] + after 50 [list fileevent $newsock readable [list httpdRead $newsock]] } # read data from a client request diff --git a/tests/info.test b/tests/info.test index ebc853a..3057dd2 100644 --- a/tests/info.test +++ b/tests/info.test @@ -1962,6 +1962,440 @@ test info-9.13 {info level option, value in global context} -body { } -returnCodes error -result {bad level "2"} # ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + catch {*}{ + {info frame 0} + res + } + return $res +} +test info-33.4 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1968 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + dict for {a b} {c d} {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.5 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1983 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + set d {a b} + dict update d x y {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.6 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 1998 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + set d {} + dict with d {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.7 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2013 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {set res [info frame 0]} + {1} {} {break} + } + return $res +} +test info-33.8 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2027 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {} {1} {} + {set res [info frame 0]; break} + } + return $res +} +test info-33.9 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2043 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {} {1} + {return [info frame 0]} + {} + } +} +test info-33.10 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2058 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + for {*}{ + {} + {[return [info frame 0]]} + {} {} + } +} +test info-33.11 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2073 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + foreach {*}{ + x + } [return [info frame 0]] {} +} +test info-33.12 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2088 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + foreach {*}{ + x y + {set res [info frame 0]} + } + return $res +} +test info-33.13 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2101 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + if {*}{ + {[return [info frame 0]]} + {} + } +} +test info-33.14 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2115 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + if 0 {*}{ + {} else + {return [info frame 0]} + } +} +test info-33.15 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2130 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + incr {*}{ + x + } [return [info frame 0]] +} +test info-33.16 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2144 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + info level {*}{ + } [return [info frame 0]] +} +test info-33.17 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2156 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + string match {*}{ + } [return [info frame 0]] {} +} +test info-33.18 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2168 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + string match {*}{ + {} + } [return [info frame 0]] +} +test info-33.19 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2181 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + string length {*}{ + } [return [info frame 0]] +} +test info-33.20 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2193 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + while {*}{ + {[return [info frame 0]]} + } {} +} +test info-33.21 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2205 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + switch -- {*}{ + } [return [info frame 0]] {*}{ + } x y +} +test info-33.22 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2218 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } + return $res +} +test info-33.23 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2231 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } finally {} + return $res +} +test info-33.24 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2245 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } on ok {} {} + return $res +} +test info-33.25 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2259 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {*}{ + {set res [info frame 0]} + } on ok {} {} finally {} + return $res +} +test info-33.26 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2273 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + while 1 {*}{ + {return [info frame 0]} + } +} +test info-33.27 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2287 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} finally {*}{ + {return [info frame 0]} + } +} +test info-33.28 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2300 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} on ok {} {} finally {*}{ + {return [info frame 0]} + } +} +test info-33.29 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2313 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} on ok {} {*}{ + {return [info frame 0]} + } +} +test info-33.30 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2326 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + try {} on ok {} {*}{ + {return [info frame 0]} + } finally {} +} +test info-33.31 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2339 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + binary format {*}{ + } [return [info frame 0]] +} +test info-33.32 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2352 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + set format format + binary $format {*}{ + } [return [info frame 0]] +} +test info-33.33 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2365 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + append x {*}{ + } [return [info frame 0]] +} +test info-33.34 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2377 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- +namespace eval foo {} +proc foo::bar {} { + append {*}{ + } x([return [info frame 0]]) {*}{ + } a +} +test info-33.35 {{*}, literal, simple, bytecompiled} -body { + reduce [foo::bar] +} -cleanup { + namespace delete foo +} -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- unset -nocomplain res # cleanup diff --git a/tests/interp.test b/tests/interp.test index 0af9887..ad99fac 100644 --- a/tests/interp.test +++ b/tests/interp.test @@ -1599,6 +1599,20 @@ test interp-20.50 {Bug 2486550} -setup { } -cleanup { interp delete slave } -returnCodes error -match glob -result * +test interp-20.50.1 {Bug 2486550} -setup { + interp create slave +} -body { + slave hide coroutine + catch {slave invokehidden coroutine} m o + dict get $o -errorinfo +} -cleanup { + unset -nocomplain m 0 + interp delete slave +} -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?" + while executing +"coroutine" + invoked from within +"slave invokehidden coroutine"} test interp-21.1 {interp hidden} { interp hidden {} diff --git a/tests/load.test b/tests/load.test index cded85d..9536271 100644 --- a/tests/load.test +++ b/tests/load.test @@ -215,6 +215,12 @@ test load-10.1 {load from vfs} \ -body {list [catch {load simplefs:/pkgd$ext pkgd} msg] $msg} \ -result {0 {}} \ -cleanup {testsimplefilesystem 0; cd $dir; unset dir} + +test load-11.1 {Load TclOO extension using Stubs (Bug [f51efe99a7])} \ + [list $dll $loaded] { + load [file join $testDir pkgooa$ext] + list [pkgooa_stubsok] [lsort [info commands pkgooa_*]] +} {1 pkgooa_stubsok} # cleanup unset ext diff --git a/tests/misc.test b/tests/misc.test index 6ddc718..d4ece74 100644 --- a/tests/misc.test +++ b/tests/misc.test @@ -59,12 +59,7 @@ test misc-1.2 {error in variable ref. in command in array reference} { missing close-brace for variable name missing close-brace for variable name while executing -"set tst $a([winfo name $\{zz) - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a bogus comment - # this is a ..." +"set tst $a([winfo name $\{" (procedure "tstProc" line 4) invoked from within "tstProc"}] diff --git a/tests/namespace.test b/tests/namespace.test index f6688f1..8c4b81c 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -558,6 +558,15 @@ test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} { lappend l [info commands ::test_ns_import::*] } } {::test_ns_import::cmd1 {}} +test namespace-13.2 {DeleteImportedCmd, Bug a4494e28ed} { + # Will panic if still buggy + namespace eval src {namespace export foo; proc foo {} {}} + namespace eval dst {namespace import [namespace parent]::src::foo} + trace add command src::foo delete \ + "[list namespace delete [namespace current]::dst] ;#" + proc src::foo {} {} + namespace delete src +} {} test namespace-14.1 {TclGetNamespaceForQualName, absolute names} { catch {namespace delete {*}[namespace children :: test_ns_*]} diff --git a/tests/oo.test b/tests/oo.test index 49fe150..d63e931 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -2,12 +2,12 @@ # Sourcing this file into Tcl runs the tests and generates output for errors. # No output means no errors were found. # -# Copyright (c) 2006-2012 Donal K. Fellows +# Copyright (c) 2006-2013 Donal K. Fellows # # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0 +package require TclOO 1.0.1 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* @@ -101,7 +101,7 @@ test oo-0.8 {leak in variable management} -setup { test oo-0.9 {various types of presence of the TclOO package} { list [lsearch -nocase -all -inline [package names] tcloo] \ [package present TclOO] [package versions TclOO] -} [list TclOO $::oo::version $::oo::version] +} [list TclOO $::oo::patchlevel $::oo::patchlevel] test oo-1.1 {basic test of OO functionality: no classes} { set result {} @@ -936,6 +936,69 @@ test oo-6.18 {Bug 3408830: more forwarding cases} -setup { } -returnCodes error -cleanup { fooClass destroy } -result {wrong # args: should be "::foo len string"} +test oo-6.19 {Bug 3610404: forwarding resolution + traces} -setup { + oo::object create foo + unset -nocomplain ::result + set ::result {} +} -body { + proc ::my {method} {lappend ::result global} + oo::objdefine foo { + method target {} {lappend ::result instance} + forward bar my target + method bump {} { + set ns [info object namespace ::foo] + rename ${ns}::my ${ns}:: + rename ${ns}:: ${ns}::my + } + } + proc harness {} { + foo target + foo bar + foo target + } + trace add execution harness enterstep {apply {{cmd args} {foo bump}}} + foo target + foo bar + foo bump + foo bar + harness +} -cleanup { + catch {rename harness {}} + catch {rename ::my {}} + foo destroy +} -result {instance instance instance instance instance instance} +test oo-6.20 {Bug 3610404: forwarding resolution + traces} -setup { + oo::class create fooClass + fooClass create foo + unset -nocomplain ::result + set ::result {} +} -body { + proc ::my {method} {lappend ::result global} + oo::define fooClass { + method target {} {lappend ::result class} + forward bar my target + method bump {} { + set ns [info object namespace [self]] + rename ${ns}::my ${ns}:: + rename ${ns}:: ${ns}::my + } + } + proc harness {} { + foo target + foo bar + foo target + } + trace add execution harness enterstep {apply {{cmd args} {foo bump}}} + foo target + foo bar + foo bump + foo bar + harness +} -cleanup { + catch {rename harness {}} + catch {rename ::my {}} + fooClass destroy +} -result {class class class class class class} test oo-7.1 {OO: inheritance 101} -setup { oo::class create superClass @@ -1776,6 +1839,36 @@ test oo-15.9 {ensemble rewriting must not bleed through oo::copy} -setup { } -returnCodes error -cleanup { Foo destroy } -result {wrong # args: should be "::bar <cloned> a b"} +test oo-15.10 {variable binding must not bleed through oo::copy} -setup { + oo::class create FooClass + set result {} +} -body { + set obj1 [FooClass new] + oo::objdefine $obj1 { + variable var + method m {} { + set var foo + } + method get {} { + return $var + } + export eval + } + + $obj1 m + lappend result [$obj1 get] + set obj2 [oo::copy $obj1] + $obj2 eval { + set var bar + } + lappend result [$obj2 get] + $obj1 eval { + set var grill + } + lappend result [$obj1 get] [$obj2 get] +} -cleanup { + FooClass destroy +} -result {foo bar grill bar} test oo-16.1 {OO: object introspection} -body { info object @@ -3374,6 +3467,42 @@ test oo-34.8 {TIP 380: slots - presence} { test oo-34.9 {TIP 380: slots - presence} { getMethods oo::objdefine::variable } {{-append -clear -set} {Get Set}} + +test oo-35.1 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { + oo::class create fruit { + method eat {} {} + } + set result {} +} -body { + lappend result [fruit create ::apple] [info class superclasses fruit] + oo::define fruit superclass + lappend result [info class superclasses fruit] \ + [info object class apple oo::object] \ + [info class call fruit destroy] \ + [catch { apple }] +} -cleanup { + unset -nocomplain result + fruit destroy +} -result {::apple ::oo::object ::oo::object 1 {{method destroy ::oo::object {core method: "destroy"}}} 1} +test oo-35.2 {Bug 9d61624b3d: Empty superclass must not cause crash} -setup { + oo::class create fruitMetaclass { + superclass oo::class + method eat {} {} + } + set result {} +} -body { + lappend result [fruitMetaclass create ::appleClass] \ + [appleClass create orange] \ + [info class superclasses fruitMetaclass] + oo::define fruitMetaclass superclass + lappend result [info class superclasses fruitMetaclass] \ + [info object class appleClass oo::class] \ + [catch { orange }] [info object class orange] \ + [appleClass create pear] +} -cleanup { + unset -nocomplain result + fruitMetaclass destroy +} -result {::appleClass ::orange ::oo::class ::oo::class 1 1 ::appleClass ::pear} cleanupTests return diff --git a/tests/ooNext2.test b/tests/ooNext2.test index d77e8d1..a47aa91 100644 --- a/tests/ooNext2.test +++ b/tests/ooNext2.test @@ -7,7 +7,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. -package require TclOO 1.0 +package require TclOO 1.0.1 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* diff --git a/tests/parse.test b/tests/parse.test index b9cfe80..01443c9 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -27,6 +27,7 @@ testConstraint testparsevar [llength [info commands testparsevar]] testConstraint testasync [llength [info commands testasync]] testConstraint testcmdtrace [llength [info commands testcmdtrace]] testConstraint testevent [llength [info commands testevent]] +testConstraint memory [llength [info commands memory]] test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser { testparser [bytestring "foo\0 bar"] -1 @@ -678,6 +679,26 @@ test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar unset -nocomplain abc list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg } {1 {invalid command name "bogus"}} +test parse-13.6 {Tcl_ParseVar memory leak} -constraints memory -setup { + proc getbytes {} { + return [lindex [split [memory info] \n] 3 3] + } +} -body { + set a() foo + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + set vn {} + set res [testparsevar [append vn $ a([string repeat {[]} 19]) bar]] + if {$res ne {foo bar}} {error "Unexpected result: $res"} + + set tmp $end + set end [getbytes] + } + expr {$end - $tmp} +} -cleanup { + unset -nocomplain a end i vn res tmp + rename getbytes {} +} -result 0 test parse-14.1 {Tcl_ParseBraces procedure, computing string length} testparser { testparser [bytestring "foo\0 bar"] -1 @@ -1097,6 +1118,12 @@ test parse-21.0 {Bug 1884496} testevent { testevent queue a head $::script vwait done } {} +test parse-21.1 {TCL_EVAL_DIRECT coverage} testevent { + testevent queue a head {testevent delete a; \ + set ::done [dict get [info frame 0] line]} + vwait done + set ::done +} 2 cleanupTests } diff --git a/tests/reg.test b/tests/reg.test index b653d4b..5cc81fe 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -1149,6 +1149,9 @@ 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} { + 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 # cleanup ::tcltest::cleanupTests diff --git a/tests/regexp.test b/tests/regexp.test index 1c30001..1b2bec9 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -876,6 +876,10 @@ test regexp-22.5 {Bug 3610026} -setup { } -cleanup { unset -nocomplain e cp } -returnCodes error -match glob -result {*too many colors*} +test regexp-22.6 {Bug 6585b21ca8} { + expr {[regexp {(\w).*?\1} Programmer m] ? $m : "<NONE>"} +} rogr + test regexp-23.1 {regexp -all and -line} { set string "" diff --git a/tests/rename.test b/tests/rename.test index 1fa0441..ebf5425 100644 --- a/tests/rename.test +++ b/tests/rename.test @@ -140,6 +140,13 @@ test rename-4.7 {reentrancy issues with command deletion and renaming} testdel { if {[info exists env(value)]} { unset env(value) } +test rename-4.8 {Bug a16752c252} testdel { + set x broken + testdel {} foo {set x ok} + proc foo args {} + rename foo {} + return -level 0 $x[unset x] +} ok # Save the unknown procedure which is modified by the following test. diff --git a/tests/safe.test b/tests/safe.test index 423e10e..d41708b 100644 --- a/tests/safe.test +++ b/tests/safe.test @@ -425,6 +425,19 @@ test safe-10.1 {testing statics loading} -constraints TcltestPackage -setup { } -returnCodes error -cleanup { safe::interpDelete $i } -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +test safe-10.1.1 {testing statics loading} -constraints TcltestPackage -setup { + set i [safe::interpCreate] +} -body { + catch {interp eval $i {load {} Safepkg1}} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure + invoked from within +"load {} Safepkg1" + invoked from within +"interp eval $i {load {} Safepkg1}"} test safe-10.2 {testing statics loading / -nostatics} -constraints TcltestPackage -body { set i [safe::interpCreate -nostatics] interp eval $i {load {} Safepkg1} @@ -444,6 +457,18 @@ test safe-10.4 {testing nested statics loading / -nestedloadok} -constraints Tcl } -returnCodes error -cleanup { safe::interpDelete $i } -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure} +test safe-10.4.1 {testing nested statics loading / -nestedloadok} -constraints TcltestPackage -body { + set i [safe::interpCreate -nestedloadok] + catch {interp eval $i {interp create x; load {} Safepkg1 x}} m o + dict get $o -errorinfo +} -returnCodes ok -cleanup { + unset -nocomplain m o + safe::interpDelete $i +} -result {can't use package in a safe interpreter: no Safepkg1_SafeInit procedure + invoked from within +"load {} Safepkg1 x" + invoked from within +"interp eval $i {interp create x; load {} Safepkg1 x}"} test safe-11.1 {testing safe encoding} -setup { set i [safe::interpCreate] @@ -501,6 +526,23 @@ test safe-11.7 {testing safe encoding} -setup { } -returnCodes error -cleanup { safe::interpDelete $i } -result {wrong # args: should be "encoding convertfrom ?encoding? data"} +test safe-11.7.1 {testing safe encoding} -setup { + set i [safe::interpCreate] +} -body { + catch {interp eval $i encoding convertfrom} m o + dict get $o -errorinfo +} -returnCodes ok -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" + invoked from within +"encoding convertfrom" + invoked from within +"interp eval $i encoding convertfrom"} test safe-11.8 {testing safe encoding} -setup { set i [safe::interpCreate] } -body { @@ -508,6 +550,23 @@ test safe-11.8 {testing safe encoding} -setup { } -returnCodes error -cleanup { safe::interpDelete $i } -result {wrong # args: should be "encoding convertto ?encoding? data"} +test safe-11.8.1 {testing safe encoding} -setup { + set i [safe::interpCreate] +} -body { + catch {interp eval $i encoding convertto} m o + dict get $o -errorinfo +} -returnCodes ok -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" + invoked from within +"encoding convertto" + invoked from within +"interp eval $i encoding convertto"} test safe-12.1 {glob is restricted [Bug 2906841]} -setup { set i [safe::interpCreate] @@ -715,8 +774,29 @@ test safe-15.1 {safe file ensemble does not surprise code} -setup { lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg } -cleanup { + unset -nocomplain msg interp delete $i } -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file}} +test safe-15.1.1 {safe file ensemble does not surprise code} -setup { + set i [interp create -safe] +} -body { + set result [expr {"file" in [interp hidden $i]}] + lappend result [interp eval $i {tcl::file::split a/b/c}] + lappend result [catch {interp eval $i {tcl::file::isdirectory .}}] + lappend result [interp invokehidden $i file split a/b/c] + lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg + lappend result [catch {interp invokehidden $i file isdirectory .}] + interp expose $i file + lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg + lappend result [catch {interp eval $i {file isdirectory .}} msg o] [dict get $o -errorinfo] +} -cleanup { + unset -nocomplain msg o + interp delete $i +} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {not allowed to invoke subcommand isdirectory of file + while executing +"file isdirectory ." + invoked from within +"interp eval $i {file isdirectory .}"}} ### ~ should have no special meaning in paths in safe interpreters test safe-16.1 {Bug 3529949: defang ~ in paths} -setup { diff --git a/tests/scan.test b/tests/scan.test index ea0c500..b57b641 100644 --- a/tests/scan.test +++ b/tests/scan.test @@ -375,6 +375,12 @@ test scan-4.48 {Tcl_ScanObjCmd, float scanning} { test scan-4.49 {Tcl_ScanObjCmd, float scanning} { list [scan {.1 0.2 3.} {%e %f %g} x y z] $x $y $z } {3 0.1 0.2 3.0} +test scan-4.49-uc-1 {Tcl_ScanObjCmd, float scanning} { + list [scan {0.5*0.75} {%E%c%G} x y z] $x $y $z +} {3 0.5 42 0.75} +test scan-4.49-uc-2 {Tcl_ScanObjCmd, float scanning} { + list [scan {5e-1*75E-2} {%E%c%G} x y z] $x $y $z +} {3 0.5 42 0.75} test scan-4.50 {Tcl_ScanObjCmd, float scanning} { list [scan {1234567890a} %f x] $x } {1 1234567890.0} @@ -450,6 +456,9 @@ test scan-4.63 {scanning of large and negative hex integers} { list [scan $scanstring {%x %x %x} a b c] \ [expr { $a == -1 }] [expr { $b == $MIN_INT }] [expr { $c == $MAX_INT }] } {3 1 1 1} +test scan-4.64 {scanning of hex with %X} { + scan "123 abc f78" %X%X%X +} {291 2748 3960} test scan-5.1 {integer scanning} -setup { set a {}; set b {}; set c {}; set d {} @@ -626,14 +635,14 @@ test scan-8.4 {error conditions} -returnCodes error -body { scan a %O x } -result {bad scan conversion character "O"} test scan-8.5 {error conditions} -returnCodes error -body { - scan a %X x -} -result {bad scan conversion character "X"} + scan a %B x +} -result {bad scan conversion character "B"} test scan-8.6 {error conditions} -returnCodes error -body { scan a %F x } -result {bad scan conversion character "F"} test scan-8.7 {error conditions} -returnCodes error -body { - scan a %E x -} -result {bad scan conversion character "E"} + scan a %p x +} -result {bad scan conversion character "p"} test scan-8.8 {error conditions} -returnCodes error -body { scan a "%d %d" a } -result {different numbers of variable names and field specifiers} diff --git a/tests/socket.test b/tests/socket.test index 5542c09..51219e6 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -1841,6 +1841,7 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \ after cancel $after close $client close $server + unset x } -result {{} bye} test socket-14.5 {[socket -async] which fails before any connect() can be made} \ -constraints [list socket supported_any] \ @@ -1850,6 +1851,33 @@ test socket-14.5 {[socket -async] which fails before any connect() can be made} } \ -returnCodes 1 \ -result {couldn't open socket: cannot assign requested address} +test socket-14.6 {[socket -async] with no event loop and [fconfigure -error] before the socket is connected} \ + -constraints [list socket supported_inet supported_inet6] \ + -setup { + proc accept {s a p} { + puts $s bye + close $s + } + set server [socket -server accept -myaddr 127.0.0.1 0] + set port [lindex [fconfigure $server -sockname] 2] + set x "" + } \ + -body { + set client [socket -async localhost $port] + foreach _ {1 2} { + lappend x [lindex [fconfigure $client -sockname] 0] + lappend x [fconfigure $client -error] + update + } + lappend x [gets $client] + } \ + -cleanup { + close $server + close $client + unset x + } \ + -result [list ::1 "connection refused" 127.0.0.1 "" bye] + ::tcltest::cleanupTests flush stdout return diff --git a/tests/source.test b/tests/source.test index d71212d..0235bd1 100644 --- a/tests/source.test +++ b/tests/source.test @@ -187,6 +187,16 @@ test source-3.5 {return with special code etc.} -setup { invoked from within "source $sourcefile"} {a b c}} +test source-4.1 {continuation line parsing} -setup { + set sourcefile [makeFile [string map {CL \\\n} { + format %s "[dict get [info frame 0] type]:CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]CL[dict get [info frame 0] line]" + }] source.file] +} -body { + source $sourcefile +} -cleanup { + removeFile source.file +} -result {source: 3 4 5} + test source-6.1 {source is binary ok} -setup { # Note [makeFile] writes in the system encoding. # [source] defaults to reading in the system encoding. diff --git a/tests/subst.test b/tests/subst.test index 4be4798..7466895 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -293,6 +293,10 @@ test subst-13.1 {Bug 3081065} -setup { } -cleanup { removeFile subst13.tcl } +test subst-13.2 {Test for segfault} -body { + subst {[} +} -returnCodes error -result * -match glob + # cleanup ::tcltest::cleanupTests diff --git a/tests/trace.test b/tests/trace.test index a3a5604..d830f3c 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -2661,6 +2661,13 @@ test trace-39.1 {bug #3485022: tracing Bc'ed commands} -setup { rename dotrace {} rename foo {} } -result {3 | 0 1 1} + +test trace-40.1 {execution trace errors become command errors} { + proc foo args {} + trace add execution foo enter {rename foo {}; error bar;#} + 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). diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test new file mode 100644 index 0000000..120f362 --- /dev/null +++ b/tests/unixForkEvent.test @@ -0,0 +1,45 @@ +# This file contains a collection of tests for the procedures in the file +# tclUnixNotify.c. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 1995-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require tcltest 2 +namespace import -force ::tcltest::* + +testConstraint testfork [llength [info commands testfork]] + +# Test if the notifier thread is well initialized in a forked interpreter +# by Tcl_InitNotifier +test unixforkevent-1.1 {fork and test writeable event} \ + -constraints {testfork nonPortable} \ + -body { + set myFolder [makeDirectory unixtestfork] + set pid [testfork] + if {$pid == 0} { + # we are the forked process + set result initialized + set h [open [file join $myFolder test.txt] w] + fileevent $h writable\ + "set result writable;\ + after cancel [after 1000 {set result timeout}]" + vwait result + close $h + makeFile $result result.txt $myFolder + exit + } + # we are the original process + while {![file readable [file join $myFolder result.txt]]} {} + viewFile result.txt $myFolder + } \ + -result {writable} \ + -cleanup { + catch { removeFolder $myFolder } + } + +::tcltest::cleanupTests +return diff --git a/tests/upvar.test b/tests/upvar.test index e2c9ffd..e93f58a 100644 --- a/tests/upvar.test +++ b/tests/upvar.test @@ -414,6 +414,17 @@ test upvar-9.7 {Tcl_UpVar procedure} testupvar { } {1234} catch {unset a} +test upvar-10.1 {CompileWord OBOE} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + upvar 1 {*}{ + } [return [incr n -[linenumber]]] x + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 + # # Tests for 'namespace upvar'. As the implementation is essentially the same as # for 'upvar', we only test that the variables are linked correctly, i.e., we @@ -536,6 +547,38 @@ test upvar-NS-2.2 {TIP 323} -setup { } -cleanup { namespace delete test_ns_1 } -result {} + +test upvar-NS-3.1 {CompileWord OBOE} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + namespace upvar {*}{ + } [return [incr n -[linenumber]]] x y + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 +test upvar-NS-3.2 {CompileWord OBOE} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + namespace upvar :: {*}{ + } [return [incr n -[linenumber]]] x + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 +test upvar-NS-3.3 {CompileWord OBOE} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + variable x {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 + # cleanup ::tcltest::cleanupTests diff --git a/tests/utf.test b/tests/utf.test index c41cfe3..ebab967 100644 --- a/tests/utf.test +++ b/tests/utf.test @@ -337,8 +337,8 @@ test utf-21.11 {TclUniCharIsControl} { string is control \u00ad } {1} test utf-21.12 {unicode control char in regc_locale.c} { - # [Bug 3464428] - regexp {^[[:cntrl:]]$} \u00ad + # [Bug 3464428], [Bug a876646efe] + regexp {^[[:cntrl:]]*$} \u0000\u001f\u00ad } {1} test utf-22.1 {TclUniCharIsWordChar} { diff --git a/tests/var.test b/tests/var.test index 5939100..208b361 100644 --- a/tests/var.test +++ b/tests/var.test @@ -748,6 +748,9 @@ test var-15.1 {segfault in [unset], [Bug 735335]} { namespace eval test A useSomeUnlikelyNameHere namespace eval test unset useSomeUnlikelyNameHere } {} +test var-15.2 {compiled unset evaluation order, Bug 3970f54c4e} { + apply {{} {unset foo [return ok]}} +} ok test var-16.1 {CallVarTraces: save/restore interp error state} { trace add variable ::errorCode write " ;#" @@ -862,6 +865,19 @@ test var-20.8 {array set compilation correctness: Bug 3603163} -setup { }} array size x } -result 0 + +test var-21.0 {PushVarNameWord OBOE in compiled unset} -setup { + proc linenumber {} {dict get [info frame -1] line} +} -body { + apply {n { + set foo bar + unset foo {*}{ + } [return [incr n -[linenumber]]] + }} [linenumber] +} -cleanup { + rename linenumber {} +} -result 1 + catch {namespace delete ns} catch {unset arr} diff --git a/tests/zlib.test b/tests/zlib.test index c469eea..4e51ebb 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -16,6 +16,13 @@ if {"::tcltest" ni [namespace children]} { } testConstraint zlib [llength [info commands zlib]] +testConstraint recentZlib 0 +catch { + # Work around a bug in some versions of zlib; known to manifest on at + # least Mac OS X Mountain Lion... + testConstraint recentZlib \ + [package vsatisfies [zlib::pkgconfig get zlibVersion] 1.2.6] +} test zlib-1.1 {zlib basics} -constraints zlib -returnCodes error -body { zlib @@ -233,7 +240,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" -test zlib-8.8 {transformtion and fconfigure} -setup { +test zlib-8.8 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push compress $outSide -dictionary $spdyDict @@ -250,7 +257,7 @@ test zlib-8.8 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} } -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010} -test zlib-8.9 {transformtion and fconfigure} -setup { +test zlib-8.9 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream decompress] } -constraints zlib -body { @@ -267,16 +274,19 @@ test zlib-8.9 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {3064818174 358 358} -test zlib-8.10 {transformtion and fconfigure} -setup { +test zlib-8.10 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide -} -constraints zlib -body { +} -constraints {zlib recentZlib} -body { zlib push deflate $outSide -dictionary $spdyDict fconfigure $outSide -blocking 0 -translation binary -buffering none fconfigure $inSide -blocking 0 -translation binary puts -nonewline $outSide $spdyHeaders chan pop $outSide set compressed [read $inSide] - catch {zlib inflate $compressed} err opt + catch { + zlib inflate $compressed + throw UNREACHABLE "should be unreachable" + } err opt list [string length [zlib deflate $spdyHeaders]] \ [string length $compressed] \ $err [dict get $opt -errorcode] @@ -284,7 +294,7 @@ test zlib-8.10 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} } -result {254 212 {data error} {TCL ZLIB DATA}} -test zlib-8.11 {transformtion and fconfigure} -setup { +test zlib-8.11 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream inflate] } -constraints zlib -body { @@ -300,7 +310,7 @@ test zlib-8.11 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.12 {transformtion and fconfigure} -setup { +test zlib-8.12 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { @@ -317,7 +327,7 @@ test zlib-8.12 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} -test zlib-8.13 {transformtion and fconfigure} -setup { +test zlib-8.13 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { @@ -334,7 +344,7 @@ test zlib-8.13 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} -test zlib-8.14 {transformtion and fconfigure} -setup { +test zlib-8.14 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { @@ -350,7 +360,7 @@ test zlib-8.14 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.15 {transformtion and fconfigure} -setup { +test zlib-8.15 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { |