os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/compile.test
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/compile.test Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,443 @@
1.4 +# This file contains tests for the files tclCompile.c, tclCompCmds.c
1.5 +# and tclLiteral.c
1.6 +#
1.7 +# This file contains a collection of tests for one or more of the Tcl
1.8 +# built-in commands. Sourcing this file into Tcl runs the tests and
1.9 +# generates output for errors. No output means no errors were found.
1.10 +#
1.11 +# Copyright (c) 1997 by Sun Microsystems, Inc.
1.12 +# Copyright (c) 1998-1999 by Scriptics Corporation.
1.13 +#
1.14 +# See the file "license.terms" for information on usage and redistribution
1.15 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.16 +#
1.17 +# RCS: @(#) $Id: compile.test,v 1.24.2.3 2004/10/26 20:14:36 dgp Exp $
1.18 +
1.19 +package require tcltest 2
1.20 +namespace import -force ::tcltest::*
1.21 +
1.22 +# The following tests are very incomplete, although the rest of the
1.23 +# test suite covers this file fairly well.
1.24 +
1.25 +catch {rename p ""}
1.26 +catch {namespace delete test_ns_compile}
1.27 +catch {unset x}
1.28 +catch {unset y}
1.29 +catch {unset a}
1.30 +
1.31 +test compile-1.1 {TclCompileString: look up cmds in proc ns, not current ns} {
1.32 + catch {namespace delete test_ns_compile}
1.33 + catch {unset x}
1.34 + set x 123
1.35 + namespace eval test_ns_compile {
1.36 + proc set {args} {
1.37 + global x
1.38 + lappend x test_ns_compile::set
1.39 + }
1.40 + proc p {} {
1.41 + set 0
1.42 + }
1.43 + }
1.44 + list [test_ns_compile::p] [set x]
1.45 +} {{123 test_ns_compile::set} {123 test_ns_compile::set}}
1.46 +test compile-1.2 {TclCompileString, error result is reset if TclGetLong determines word isn't an integer} {
1.47 + proc p {x} {info commands 3m}
1.48 + list [catch {p} msg] $msg
1.49 +} {1 {wrong # args: should be "p x"}}
1.50 +test compile-2.1 {TclCompileDollarVar: global scalar name with ::s} {
1.51 + catch {unset x}
1.52 + set x 123
1.53 + list $::x [expr {[lsearch -exact [info globals] x] != 0}]
1.54 +} {123 1}
1.55 +test compile-2.2 {TclCompileDollarVar: global scalar name with ::s} {
1.56 + catch {unset y}
1.57 + proc p {} {
1.58 + set ::y 789
1.59 + return $::y
1.60 + }
1.61 + list [p] $::y [expr {[lsearch -exact [info globals] y] != 0}]
1.62 +} {789 789 1}
1.63 +test compile-2.3 {TclCompileDollarVar: global array name with ::s} {
1.64 + catch {unset a}
1.65 + set ::a(1) 2
1.66 + list $::a(1) [set ::a($::a(1)) 3] $::a(2) [expr {[lsearch -exact [info globals] a] != 0}]
1.67 +} {2 3 3 1}
1.68 +test compile-2.4 {TclCompileDollarVar: global scalar name with ::s} {
1.69 + catch {unset a}
1.70 + proc p {} {
1.71 + set ::a(1) 1
1.72 + return $::a($::a(1))
1.73 + }
1.74 + list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
1.75 +} {1 1 1}
1.76 +test compile-2.5 {TclCompileDollarVar: global array, called as ${arrName(0)}} {
1.77 + catch {unset a}
1.78 + proc p {} {
1.79 + global a
1.80 + set a(1) 1
1.81 + return ${a(1)}$::a(1)$a(1)
1.82 + }
1.83 + list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
1.84 +} {111 1 1}
1.85 +
1.86 +test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} {
1.87 + catch {unset a}
1.88 + set a(1) xyzzyx
1.89 + proc p {} {
1.90 + global a
1.91 + catch {set x 123} a(1)
1.92 + }
1.93 + list [p] $a(1)
1.94 +} {0 123}
1.95 +test compile-3.2 {TclCompileCatchCmd: non-local variables} {
1.96 + set ::foo 1
1.97 + proc catch-test {} {
1.98 + catch {set x 3} ::foo
1.99 + }
1.100 + catch-test
1.101 + set ::foo
1.102 +} 3
1.103 +test compile-3.3 {TclCompileCatchCmd: overagressive compiling [bug 219184]} {
1.104 + proc catch-test {str} {
1.105 + catch [eval $str GOOD]
1.106 + error BAD
1.107 + }
1.108 + catch {catch-test error} ::foo
1.109 + set ::foo
1.110 +} {GOOD}
1.111 +test compile-3.4 {TclCompileCatchCmd: bcc'ed [return] is caught} {
1.112 + proc foo {} {
1.113 + set fail [catch {
1.114 + return 1
1.115 + }] ; # {}
1.116 + return 2
1.117 + }
1.118 + foo
1.119 +} {2}
1.120 +
1.121 +test compile-3.5 {TclCompileCatchCmd: recover from error, [Bug 705406]} {
1.122 + proc foo {} {
1.123 + catch {
1.124 + if {[a]} {
1.125 + if b {}
1.126 + }
1.127 + }
1.128 + }
1.129 + list [catch foo msg] $msg
1.130 +} {0 1}
1.131 +
1.132 +test compile-4.1 {TclCompileForCmd: command substituted test expression} {
1.133 + set i 0
1.134 + set j 0
1.135 + # Should be "forever"
1.136 + for {} [expr $i < 3] {} {
1.137 + set j [incr i]
1.138 + if {$j > 3} break
1.139 + }
1.140 + set j
1.141 +} {4}
1.142 +
1.143 +test compile-5.1 {TclCompileForeachCmd: exception stack} {
1.144 + proc foreach-exception-test {} {
1.145 + foreach array(index) [list 1 2 3] break
1.146 + foreach array(index) [list 1 2 3] break
1.147 + foreach scalar [list 1 2 3] break
1.148 + }
1.149 + list [catch foreach-exception-test result] $result
1.150 +} {0 {}}
1.151 +test compile-5.2 {TclCompileForeachCmd: non-local variables} {
1.152 + set ::foo 1
1.153 + proc foreach-test {} {
1.154 + foreach ::foo {1 2 3} {}
1.155 + }
1.156 + foreach-test
1.157 + set ::foo
1.158 +} 3
1.159 +
1.160 +test compile-6.1 {TclCompileSetCmd: global scalar names with ::s} {
1.161 + catch {unset x}
1.162 + catch {unset y}
1.163 + set x 123
1.164 + proc p {} {
1.165 + set ::y 789
1.166 + return $::y
1.167 + }
1.168 + list $::x [expr {[lsearch -exact [info globals] x] != 0}] \
1.169 + [p] $::y [expr {[lsearch -exact [info globals] y] != 0}]
1.170 +} {123 1 789 789 1}
1.171 +test compile-6.2 {TclCompileSetCmd: global array names with ::s} {
1.172 + catch {unset a}
1.173 + set ::a(1) 2
1.174 + proc p {} {
1.175 + set ::a(1) 1
1.176 + return $::a($::a(1))
1.177 + }
1.178 + list $::a(1) [p] [set ::a($::a(1)) 3] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
1.179 +} {2 1 3 3 1}
1.180 +test compile-6.3 {TclCompileSetCmd: namespace var names with ::s} {
1.181 + catch {namespace delete test_ns_compile}
1.182 + catch {unset x}
1.183 + namespace eval test_ns_compile {
1.184 + variable v hello
1.185 + variable arr
1.186 + set ::x $::test_ns_compile::v
1.187 + set ::test_ns_compile::arr(1) 123
1.188 + }
1.189 + list $::x $::test_ns_compile::arr(1)
1.190 +} {hello 123}
1.191 +
1.192 +test compile-7.1 {TclCompileWhileCmd: command substituted test expression} {
1.193 + set i 0
1.194 + set j 0
1.195 + # Should be "forever"
1.196 + while [expr $i < 3] {
1.197 + set j [incr i]
1.198 + if {$j > 3} break
1.199 + }
1.200 + set j
1.201 +} {4}
1.202 +
1.203 +test compile-8.1 {CollectArgInfo: binary data} {
1.204 + list [catch "string length \000foo" msg] $msg
1.205 +} {0 4}
1.206 +test compile-8.2 {CollectArgInfo: binary data} {
1.207 + list [catch "string length foo\000" msg] $msg
1.208 +} {0 4}
1.209 +test compile-8.3 {CollectArgInfo: handle "]" at end of command properly} {
1.210 + set x ]
1.211 +} {]}
1.212 +
1.213 +test compile-9.1 {UpdateStringOfByteCode: called for duplicate of compiled empty object} {
1.214 + proc p {} {
1.215 + set x {}
1.216 + eval $x
1.217 + append x { }
1.218 + eval $x
1.219 + }
1.220 + p
1.221 +} {}
1.222 +
1.223 +test compile-10.1 {BLACKBOX: exception stack overflow} {
1.224 + set x {{0}}
1.225 + set y 0
1.226 + while {$y < 100} {
1.227 + if !$x {incr y}
1.228 + }
1.229 +} {}
1.230 +
1.231 +test compile-11.1 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
1.232 + proc p {} {
1.233 + # shared object - Interp result && Var 'r'
1.234 + set r [list foobar]
1.235 + # command that will add error to result
1.236 + lindex a bogus
1.237 + }
1.238 + list [catch {p} msg] $msg
1.239 +} {1 {bad index "bogus": must be integer or end?-integer?}}
1.240 +test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
1.241 + proc p {} { set r [list foobar] ; string index a bogus }
1.242 + list [catch {p} msg] $msg
1.243 +} {1 {bad index "bogus": must be integer or end?-integer?}}
1.244 +test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
1.245 + proc p {} { set r [list foobar] ; string index a 09 }
1.246 + list [catch {p} msg] $msg
1.247 +} {1 {bad index "09": must be integer or end?-integer? (looks like invalid octal number)}}
1.248 +test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
1.249 + proc p {} { set r [list foobar] ; array set var {one two many} }
1.250 + list [catch {p} msg] $msg
1.251 +} {1 {list must have an even number of elements}}
1.252 +test compile-11.5 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
1.253 + proc p {} { set r [list foobar] ; incr foo }
1.254 + list [catch {p} msg] $msg
1.255 +} {1 {can't read "foo": no such variable}}
1.256 +test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
1.257 + proc p {} { set r [list foobar] ; incr foo bogus }
1.258 + list [catch {p} msg] $msg
1.259 +} {1 {expected integer but got "bogus"}}
1.260 +test compile-11.7 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
1.261 + proc p {} { set r [list foobar] ; expr !a }
1.262 + list [catch {p} msg] $msg
1.263 +} {1 {syntax error in expression "!a": variable references require preceding $}}
1.264 +test compile-11.8 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
1.265 + proc p {} { set r [list foobar] ; expr {!a} }
1.266 + list [catch {p} msg] $msg
1.267 +} {1 {syntax error in expression "!a": variable references require preceding $}}
1.268 +test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} {
1.269 + proc p {} { set r [list foobar] ; llength "\{" }
1.270 + list [catch {p} msg] $msg
1.271 +} {1 {unmatched open brace in list}}
1.272 +
1.273 +#
1.274 +# Special section for tests of tclLiteral.c
1.275 +# The following tests check for incorrect memory handling in
1.276 +# TclReleaseLiteral. They are only effective when tcl is compiled
1.277 +# with TCL_MEM_DEBUG
1.278 +#
1.279 +# Special test for leak on interp delete [Bug 467523].
1.280 +::tcltest::testConstraint exec [llength [info commands exec]]
1.281 +::tcltest::testConstraint memDebug [llength [info commands memory]]
1.282 +
1.283 +test compile-12.1 {testing literal leak on interp delete} {memDebug} {
1.284 + proc getbytes {} {
1.285 + set lines [split [memory info] "\n"]
1.286 + lindex [lindex $lines 3] 3
1.287 + }
1.288 +
1.289 + set end [getbytes]
1.290 + for {set i 0} {$i < 5} {incr i} {
1.291 + interp create foo
1.292 + foo eval {
1.293 + namespace eval bar {}
1.294 + }
1.295 + interp delete foo
1.296 + set tmp $end
1.297 + set end [getbytes]
1.298 + }
1.299 + rename getbytes {}
1.300 + set leak [expr {$end - $tmp}]
1.301 +} 0
1.302 +# Special test for a memory error in a preliminary fix of [Bug 467523].
1.303 +# It requires executing a helpfile. Presumably the child process is
1.304 +# used because when this test fails, it crashes.
1.305 +test compile-12.2 {testing error on literal deletion} {memDebug exec} {
1.306 + makeFile {
1.307 + for {set i 0} {$i < 5} {incr i} {
1.308 + namespace eval bar {}
1.309 + namespace delete bar
1.310 + }
1.311 + puts 0
1.312 + } source.file
1.313 + set res [catch {
1.314 + exec [interpreter] source.file
1.315 + }]
1.316 + catch {removeFile source.file}
1.317 + set res
1.318 +} 0
1.319 +# Test to catch buffer overrun in TclCompileTokens from buf 530320
1.320 +test compile-12.3 {check for a buffer overrun} {
1.321 + proc crash {} {
1.322 + puts $array([expr {a+2}])
1.323 + }
1.324 + list [catch crash msg] $msg
1.325 +} {1 {syntax error in expression "a+2": variable references require preceding $}}
1.326 +
1.327 +test compile-12.4 {TclCleanupLiteralTable segfault} {
1.328 + # Tcl Bug 1001997
1.329 + # Here, we're trying to test a case that causes a crash in
1.330 + # TclCleanupLiteralTable. The conditions that we're trying to
1.331 + # establish are:
1.332 + # - TclCleanupLiteralTable is attempting to clean up a bytecode
1.333 + # object in the literal table.
1.334 + # - The bytecode object in question contains the only reference
1.335 + # to another literal.
1.336 + # - The literal in question is in the same hash bucket as the bytecode
1.337 + # object, and immediately follows it in the chain.
1.338 + # Since newly registered literals are added at the FRONT of the
1.339 + # bucket chains, and since the bytecode object is registered before
1.340 + # its literals, this is difficult to achieve. What we do is:
1.341 + # (a) do a [namespace eval] of a string that's calculated to
1.342 + # hash into the same bucket as a literal that it contains.
1.343 + # In this case, the script and the variable 'bugbug'
1.344 + # land in the same bucket.
1.345 + # (b) do a [namespace eval] of a string that contains enough
1.346 + # literals to force TclRegisterLiteral to rebuild the global
1.347 + # literal table. The newly created hash buckets will contain
1.348 + # the literals, IN REVERSE ORDER, thus putting the bytecode
1.349 + # immediately ahead of 'bugbug' and 'bug4345bug'. The bytecode
1.350 + # object will contain the only references to those two literals.
1.351 + # (c) Delete the interpreter to invoke TclCleanupLiteralTable
1.352 + # and tickle the bug.
1.353 + proc foo {} {
1.354 + set i [interp create]
1.355 + $i eval {
1.356 + namespace eval ::w {concat 4649; variable bugbug}
1.357 + namespace eval ::w {
1.358 + concat x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 \
1.359 + x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 \
1.360 + x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 \
1.361 + x31 x32 X33 X34 X35 X36 X37 X38 X39 X40 \
1.362 + x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 \
1.363 + x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 \
1.364 + x61 x62 x63 x64
1.365 + concat y1 y2 y3 y4 y5 y6 y7 y8 y9 y10 \
1.366 + y11 y12 y13 y14 y15 y16 y17 y18 y19 y20 \
1.367 + y21 y22 y23 y24 y25 y26 y27 y28 y29 y30 \
1.368 + y31 y32 Y33 Y34 Y35 Y36 Y37 Y38 Y39 Y40 \
1.369 + y41 y42 y43 y44 y45 y46 y47 y48 y49 y50 \
1.370 + y51 y52 y53 y54 y55 y56 y57 y58 y59 y60 \
1.371 + y61 y62 y63 y64
1.372 + concat z1 z2 z3 z4 z5 z6 z7 z8 z9 z10 \
1.373 + z11 z12 z13 z14 z15 z16 z17 z18 z19 z20 \
1.374 + z21 z22 z23 z24 z25 z26 z27 z28 z29 z30 \
1.375 + z31 z32
1.376 + }
1.377 + }
1.378 + interp delete $i; # must not crash
1.379 + return ok
1.380 + }
1.381 + foo
1.382 +} ok
1.383 +
1.384 +
1.385 +# Special test for underestimating the maxStackSize required for a
1.386 +# compiled command. A failure will cause a segfault in the child
1.387 +# process.
1.388 +test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} {
1.389 + set body {set x [list}
1.390 + for {set i 0} {$i < 3000} {incr i} {
1.391 + append body " $i"
1.392 + }
1.393 + append body {]; puts OK}
1.394 + regsub BODY {proc crash {} {BODY}; crash} $body script
1.395 + list [catch {exec [interpreter] << $script} msg] $msg
1.396 +} {0 OK}
1.397 +
1.398 +# Special test for compiling tokens from a copy of the source
1.399 +# string [Bug #599788]
1.400 +test compile-14.1 {testing errors in element name; segfault?} {} {
1.401 + catch {set a([error])} msg1
1.402 + catch {set bubba([join $abba $jubba]) $vol} msg2
1.403 + list $msg1 $msg2
1.404 +} {{wrong # args: should be "error message ?errorInfo? ?errorCode?"} {can't read "abba": no such variable}}
1.405 +
1.406 +# Next 4 tests cover Tcl Bug 633204
1.407 +test compile-15.1 {proper TCL_RETURN code from [return]} {
1.408 + proc p {} {catch return}
1.409 + set result [p]
1.410 + rename p {}
1.411 + set result
1.412 +} 2
1.413 +test compile-15.2 {proper TCL_RETURN code from [return]} {
1.414 + proc p {} {catch {return foo}}
1.415 + set result [p]
1.416 + rename p {}
1.417 + set result
1.418 +} 2
1.419 +test compile-15.3 {proper TCL_RETURN code from [return]} {
1.420 + proc p {} {catch {return $::tcl_library}}
1.421 + set result [p]
1.422 + rename p {}
1.423 + set result
1.424 +} 2
1.425 +test compile-15.4 {proper TCL_RETURN code from [return]} {
1.426 + proc p {} {catch {return [info library]}}
1.427 + set result [p]
1.428 + rename p {}
1.429 + set result
1.430 +} 2
1.431 +test compile-15.5 {proper TCL_RETURN code from [return]} {
1.432 + proc p {} {catch {set a 1}; return}
1.433 + set result [p]
1.434 + rename p {}
1.435 + set result
1.436 +} ""
1.437 +
1.438 +
1.439 +# cleanup
1.440 +catch {rename p ""}
1.441 +catch {namespace delete test_ns_compile}
1.442 +catch {unset x}
1.443 +catch {unset y}
1.444 +catch {unset a}
1.445 +::tcltest::cleanupTests
1.446 +return