os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/basic.test
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/basic.test Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,708 @@
1.4 +# This file contains tests for the tclBasic.c source file. Tests appear in
1.5 +# the same order as the C code that they test. The set of tests is
1.6 +# currently incomplete since it currently includes only new tests for
1.7 +# code changed for the addition of Tcl namespaces. Other variable-
1.8 +# related tests appear in several other test files including
1.9 +# assocd.test, cmdInfo.test, eval.test, expr.test, interp.test,
1.10 +# and trace.test.
1.11 +#
1.12 +# Sourcing this file into Tcl runs the tests and generates output for
1.13 +# errors. No output means no errors were found.
1.14 +#
1.15 +# Copyright (c) 1997 Sun Microsystems, Inc.
1.16 +# Copyright (c) 1998-1999 by Scriptics Corporation.
1.17 +#
1.18 +# See the file "license.terms" for information on usage and redistribution
1.19 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.20 +#
1.21 +# RCS: @(#) $Id: basic.test,v 1.25.2.7 2005/03/18 16:33:43 dgp Exp $
1.22 +#
1.23 +
1.24 +package require tcltest 2
1.25 +namespace import -force ::tcltest::*
1.26 +
1.27 +testConstraint testcmdtoken [llength [info commands testcmdtoken]]
1.28 +testConstraint testcmdtrace [llength [info commands testcmdtrace]]
1.29 +testConstraint testcreatecommand [llength [info commands testcreatecommand]]
1.30 +testConstraint testevalex [llength [info commands testevalex]]
1.31 +testConstraint exec [llength [info commands exec]]
1.32 +
1.33 +# This variable needs to be changed when the major or minor version number for
1.34 +# Tcl changes.
1.35 +set tclvers 8.4
1.36 +
1.37 +catch {namespace delete test_ns_basic}
1.38 +catch {interp delete test_interp}
1.39 +catch {rename p ""}
1.40 +catch {rename q ""}
1.41 +catch {rename cmd ""}
1.42 +catch {unset x}
1.43 +
1.44 +test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} {
1.45 + catch {interp delete test_interp}
1.46 + interp create test_interp
1.47 + interp eval test_interp {
1.48 + namespace eval test_ns_basic {
1.49 + proc p {} {
1.50 + return [namespace current]
1.51 + }
1.52 + }
1.53 + }
1.54 + list [interp eval test_interp {test_ns_basic::p}] \
1.55 + [interp delete test_interp]
1.56 +} {::test_ns_basic {}}
1.57 +
1.58 +test basic-2.1 {TclHideUnsafeCommands} {emptyTest} {
1.59 +} {}
1.60 +
1.61 +test basic-3.1 {Tcl_CallWhenDeleted: see dcall.test} {emptyTest} {
1.62 +} {}
1.63 +
1.64 +test basic-4.1 {Tcl_DontCallWhenDeleted: see dcall.test} {emptyTest} {
1.65 +} {}
1.66 +
1.67 +test basic-5.1 {Tcl_SetAssocData: see assoc.test} {emptyTest} {
1.68 +} {}
1.69 +
1.70 +test basic-6.1 {Tcl_DeleteAssocData: see assoc.test} {emptyTest} {
1.71 +} {}
1.72 +
1.73 +test basic-7.1 {Tcl_GetAssocData: see assoc.test} {emptyTest} {
1.74 +} {}
1.75 +
1.76 +test basic-8.1 {Tcl_InterpDeleted} {emptyTest} {
1.77 +} {}
1.78 +
1.79 +test basic-9.1 {Tcl_DeleteInterp: see interp.test} {emptyTest} {
1.80 +} {}
1.81 +
1.82 +test basic-10.1 {DeleteInterpProc, destroys interp's global namespace} {
1.83 + catch {interp delete test_interp}
1.84 + interp create test_interp
1.85 + interp eval test_interp {
1.86 + namespace eval test_ns_basic {
1.87 + namespace export p
1.88 + proc p {} {
1.89 + return [namespace current]
1.90 + }
1.91 + }
1.92 + namespace eval test_ns_2 {
1.93 + namespace import ::test_ns_basic::p
1.94 + variable v 27
1.95 + proc q {} {
1.96 + variable v
1.97 + return "[p] $v"
1.98 + }
1.99 + }
1.100 + }
1.101 + list [interp eval test_interp {test_ns_2::q}] \
1.102 + [interp eval test_interp {namespace delete ::}] \
1.103 + [catch {interp eval test_interp {set a 123}} msg] $msg \
1.104 + [interp delete test_interp]
1.105 +} {{::test_ns_basic 27} {} 1 {invalid command name "set"} {}}
1.106 +
1.107 +test basic-11.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden cmd} {
1.108 + catch {interp delete test_interp}
1.109 + interp create test_interp
1.110 + interp eval test_interp {
1.111 + proc p {} {
1.112 + return 27
1.113 + }
1.114 + }
1.115 + interp alias {} localP test_interp p
1.116 + list [interp eval test_interp {p}] \
1.117 + [localP] \
1.118 + [test_interp hide p] \
1.119 + [catch {localP} msg] $msg \
1.120 + [interp delete test_interp] \
1.121 + [catch {localP} msg] $msg
1.122 +} {27 27 {} 1 {invalid command name "p"} {} 1 {invalid command name "localP"}}
1.123 +
1.124 +# NB: More tests about hide/expose are found in interp.test
1.125 +
1.126 +test basic-12.1 {Tcl_HideCommand, names of hidden cmds can't have namespace qualifiers} {
1.127 + catch {interp delete test_interp}
1.128 + interp create test_interp
1.129 + interp eval test_interp {
1.130 + namespace eval test_ns_basic {
1.131 + proc p {} {
1.132 + return [namespace current]
1.133 + }
1.134 + }
1.135 + }
1.136 + list [catch {test_interp hide test_ns_basic::p x} msg] $msg \
1.137 + [catch {test_interp hide x test_ns_basic::p} msg1] $msg1 \
1.138 + [interp delete test_interp]
1.139 +} {1 {can only hide global namespace commands (use rename then hide)} 1 {cannot use namespace qualifiers in hidden command token (rename)} {}}
1.140 +
1.141 +test basic-12.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace} {
1.142 + catch {namespace delete test_ns_basic}
1.143 + catch {rename cmd ""}
1.144 + proc cmd {} { ;# note that this is global
1.145 + return [namespace current]
1.146 + }
1.147 + namespace eval test_ns_basic {
1.148 + proc hideCmd {} {
1.149 + interp hide {} cmd
1.150 + }
1.151 + proc exposeCmd {} {
1.152 + interp expose {} cmd
1.153 + }
1.154 + proc callCmd {} {
1.155 + cmd
1.156 + }
1.157 + }
1.158 + list [test_ns_basic::callCmd] \
1.159 + [test_ns_basic::hideCmd] \
1.160 + [catch {cmd} msg] $msg \
1.161 + [test_ns_basic::exposeCmd] \
1.162 + [test_ns_basic::callCmd] \
1.163 + [namespace delete test_ns_basic]
1.164 +} {:: {} 1 {invalid command name "cmd"} {} :: {}}
1.165 +
1.166 +test basic-13.1 {Tcl_ExposeCommand, a command stays in the global namespace and can not go to another namespace} {
1.167 + catch {namespace delete test_ns_basic}
1.168 + catch {rename cmd ""}
1.169 + proc cmd {} { ;# note that this is global
1.170 + return [namespace current]
1.171 + }
1.172 + namespace eval test_ns_basic {
1.173 + proc hideCmd {} {
1.174 + interp hide {} cmd
1.175 + }
1.176 + proc exposeCmdFailing {} {
1.177 + interp expose {} cmd ::test_ns_basic::newCmd
1.178 + }
1.179 + proc exposeCmdWorkAround {} {
1.180 + interp expose {} cmd;
1.181 + rename cmd ::test_ns_basic::newCmd;
1.182 + }
1.183 + proc callCmd {} {
1.184 + cmd
1.185 + }
1.186 + }
1.187 + list [test_ns_basic::callCmd] \
1.188 + [test_ns_basic::hideCmd] \
1.189 + [catch {test_ns_basic::exposeCmdFailing} msg] $msg \
1.190 + [test_ns_basic::exposeCmdWorkAround] \
1.191 + [test_ns_basic::newCmd] \
1.192 + [namespace delete test_ns_basic]
1.193 +} {:: {} 1 {can not expose to a namespace (use expose to toplevel, then rename)} {} ::test_ns_basic {}}
1.194 +test basic-13.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being exposed} {
1.195 + catch {rename p ""}
1.196 + catch {rename cmd ""}
1.197 + proc p {} {
1.198 + cmd
1.199 + }
1.200 + proc cmd {} {
1.201 + return 42
1.202 + }
1.203 + list [p] \
1.204 + [interp hide {} cmd] \
1.205 + [proc cmd {} {return Hello}] \
1.206 + [cmd] \
1.207 + [rename cmd ""] \
1.208 + [interp expose {} cmd] \
1.209 + [p]
1.210 +} {42 {} {} Hello {} {} 42}
1.211 +
1.212 +test basic-14.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} {testcreatecommand} {
1.213 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.214 + list [testcreatecommand create] \
1.215 + [test_ns_basic::createdcommand] \
1.216 + [testcreatecommand delete]
1.217 +} {{} {CreatedCommandProc in ::test_ns_basic} {}}
1.218 +test basic-14.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} {testcreatecommand} {
1.219 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.220 + catch {rename value:at: ""}
1.221 + list [testcreatecommand create2] \
1.222 + [value:at:] \
1.223 + [testcreatecommand delete2]
1.224 +} {{} {CreatedCommandProc2 in ::} {}}
1.225 +
1.226 +test basic-15.1 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} {
1.227 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.228 + namespace eval test_ns_basic {}
1.229 + proc test_ns_basic::cmd {} { ;# proc requires that ns already exist
1.230 + return [namespace current]
1.231 + }
1.232 + list [test_ns_basic::cmd] \
1.233 + [namespace delete test_ns_basic]
1.234 +} {::test_ns_basic {}}
1.235 +
1.236 +test basic-16.1 {TclInvokeStringCommand} {emptyTest} {
1.237 +} {}
1.238 +
1.239 +test basic-17.1 {TclInvokeObjCommand} {emptyTest} {
1.240 +} {}
1.241 +
1.242 +test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} {
1.243 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.244 + catch {rename cmd ""}
1.245 + namespace eval test_ns_basic {
1.246 + proc p {} {
1.247 + return "p in [namespace current]"
1.248 + }
1.249 + }
1.250 + list [test_ns_basic::p] \
1.251 + [rename test_ns_basic::p test_ns_basic::q] \
1.252 + [test_ns_basic::q]
1.253 +} {{p in ::test_ns_basic} {} {p in ::test_ns_basic}}
1.254 +test basic-18.2 {TclRenameCommand, existing cmd must be found} {
1.255 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.256 + list [catch {rename test_ns_basic::p test_ns_basic::q} msg] $msg
1.257 +} {1 {can't rename "test_ns_basic::p": command doesn't exist}}
1.258 +test basic-18.3 {TclRenameCommand, delete cmd if new name is empty} {
1.259 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.260 + namespace eval test_ns_basic {
1.261 + proc p {} {
1.262 + return "p in [namespace current]"
1.263 + }
1.264 + }
1.265 + list [info commands test_ns_basic::*] \
1.266 + [rename test_ns_basic::p ""] \
1.267 + [info commands test_ns_basic::*]
1.268 +} {::test_ns_basic::p {} {}}
1.269 +test basic-18.4 {TclRenameCommand, bad new name} {
1.270 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.271 + namespace eval test_ns_basic {
1.272 + proc p {} {
1.273 + return "p in [namespace current]"
1.274 + }
1.275 + }
1.276 + rename test_ns_basic::p :::george::martha
1.277 +} {}
1.278 +test basic-18.5 {TclRenameCommand, new name must not already exist} {
1.279 + namespace eval test_ns_basic {
1.280 + proc q {} {
1.281 + return 42
1.282 + }
1.283 + }
1.284 + list [catch {rename test_ns_basic::q :::george::martha} msg] $msg
1.285 +} {1 {can't rename to ":::george::martha": command already exists}}
1.286 +test basic-18.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} {
1.287 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.288 + catch {rename p ""}
1.289 + catch {rename q ""}
1.290 + proc p {} {
1.291 + return "p in [namespace current]"
1.292 + }
1.293 + proc q {} {
1.294 + return "q in [namespace current]"
1.295 + }
1.296 + namespace eval test_ns_basic {
1.297 + proc callP {} {
1.298 + p
1.299 + }
1.300 + }
1.301 + list [test_ns_basic::callP] \
1.302 + [rename q test_ns_basic::p] \
1.303 + [test_ns_basic::callP]
1.304 +} {{p in ::} {} {q in ::test_ns_basic}}
1.305 +
1.306 +test basic-19.1 {Tcl_SetCommandInfo} {emptyTest} {
1.307 +} {}
1.308 +
1.309 +test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {testcmdtoken} {
1.310 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.311 + catch {rename p ""}
1.312 + catch {rename q ""}
1.313 + catch {unset x}
1.314 + set x [namespace eval test_ns_basic::test_ns_basic2 {
1.315 + # the following creates a cmd in the global namespace
1.316 + testcmdtoken create p
1.317 + }]
1.318 + list [testcmdtoken name $x] \
1.319 + [rename ::p q] \
1.320 + [testcmdtoken name $x]
1.321 +} {{p ::p} {} {q ::q}}
1.322 +test basic-20.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} {testcmdtoken} {
1.323 + catch {rename q ""}
1.324 + set x [testcmdtoken create test_ns_basic::test_ns_basic2::p]
1.325 + list [testcmdtoken name $x] \
1.326 + [rename test_ns_basic::test_ns_basic2::p q] \
1.327 + [testcmdtoken name $x]
1.328 +} {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}}
1.329 +
1.330 +test basic-21.1 {Tcl_GetCommandName} {emptyTest} {
1.331 +} {}
1.332 +
1.333 +test basic-22.1 {Tcl_GetCommandFullName} {
1.334 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.335 + namespace eval test_ns_basic1 {
1.336 + namespace export cmd*
1.337 + proc cmd1 {} {}
1.338 + proc cmd2 {} {}
1.339 + }
1.340 + namespace eval test_ns_basic2 {
1.341 + namespace export *
1.342 + namespace import ::test_ns_basic1::*
1.343 + proc p {} {}
1.344 + }
1.345 + namespace eval test_ns_basic3 {
1.346 + namespace import ::test_ns_basic2::*
1.347 + proc q {} {}
1.348 + list [namespace which -command foreach] \
1.349 + [namespace which -command q] \
1.350 + [namespace which -command p] \
1.351 + [namespace which -command cmd1] \
1.352 + [namespace which -command ::test_ns_basic2::cmd2]
1.353 + }
1.354 +} {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2}
1.355 +
1.356 +test basic-23.1 {Tcl_DeleteCommand} {emptyTest} {
1.357 +} {}
1.358 +
1.359 +test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} {
1.360 + catch {interp delete test_interp}
1.361 + catch {unset x}
1.362 + interp create test_interp
1.363 + interp eval test_interp {
1.364 + proc useSet {} {
1.365 + return [set a 123]
1.366 + }
1.367 + }
1.368 + set x [interp eval test_interp {useSet}]
1.369 + interp eval test_interp {
1.370 + rename set ""
1.371 + proc set {args} {
1.372 + return "set called with $args"
1.373 + }
1.374 + }
1.375 + list $x \
1.376 + [interp eval test_interp {useSet}] \
1.377 + [interp delete test_interp]
1.378 +} {123 {set called with a 123} {}}
1.379 +test basic-24.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} {
1.380 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.381 + catch {rename p ""}
1.382 + proc p {} {
1.383 + return "global p"
1.384 + }
1.385 + namespace eval test_ns_basic {
1.386 + proc p {} {
1.387 + return "namespace p"
1.388 + }
1.389 + proc callP {} {
1.390 + p
1.391 + }
1.392 + }
1.393 + list [test_ns_basic::callP] \
1.394 + [rename test_ns_basic::p ""] \
1.395 + [test_ns_basic::callP]
1.396 +} {{namespace p} {} {global p}}
1.397 +test basic-24.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to a deleted cmd} {
1.398 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.399 + catch {rename p ""}
1.400 + namespace eval test_ns_basic {
1.401 + namespace export p
1.402 + proc p {} {return 42}
1.403 + }
1.404 + namespace eval test_ns_basic2 {
1.405 + namespace import ::test_ns_basic::*
1.406 + proc callP {} {
1.407 + p
1.408 + }
1.409 + }
1.410 + list [test_ns_basic2::callP] \
1.411 + [info commands test_ns_basic2::*] \
1.412 + [rename test_ns_basic::p ""] \
1.413 + [catch {test_ns_basic2::callP} msg] $msg \
1.414 + [info commands test_ns_basic2::*]
1.415 +} {42 {::test_ns_basic2::callP ::test_ns_basic2::p} {} 1 {invalid command name "p"} ::test_ns_basic2::callP}
1.416 +
1.417 +test basic-25.1 {TclCleanupCommand} {emptyTest} {
1.418 +} {}
1.419 +
1.420 +test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} {
1.421 + # If object isn't preserved, errorInfo would be set to
1.422 + # "foo\n while executing\n\"garbage bytes\"" because the object's
1.423 + # string would have been freed, leaving garbage bytes for the error
1.424 + # message.
1.425 +
1.426 + proc bgerror {args} {set ::x $::errorInfo}
1.427 + set fName [makeFile {} test1]
1.428 + set f [open $fName w]
1.429 + fileevent $f writable "fileevent $f writable {}; error foo"
1.430 + set x {}
1.431 + vwait x
1.432 + close $f
1.433 + removeFile test1
1.434 + rename bgerror {}
1.435 + set x
1.436 +} "foo\n while executing\n\"error foo\""
1.437 +
1.438 +test basic-26.2 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} {
1.439 + #
1.440 + # Follow the pure-list branch in a manner that
1.441 + # a - the pure-list internal rep is destroyed by shimmering
1.442 + # b - the command returns an error
1.443 + # As the error code in Tcl_EvalObjv accesses the list elements, this will
1.444 + # cause a segfault if [Bug 1119369] has not been fixed.
1.445 + #
1.446 +
1.447 + set SRC [list foo 1] ;# pure-list command
1.448 + proc foo str {
1.449 + # Shimmer pure-list to cmdName, cleanup and error
1.450 + proc $::SRC {} {}; $::SRC
1.451 + error "BAD CALL"
1.452 + }
1.453 + catch {eval $SRC}
1.454 +} 1
1.455 +
1.456 +test basic-27.1 {Tcl_ExprLong} {emptyTest} {
1.457 +} {}
1.458 +
1.459 +test basic-28.1 {Tcl_ExprDouble} {emptyTest} {
1.460 +} {}
1.461 +
1.462 +test basic-29.1 {Tcl_ExprBoolean} {emptyTest} {
1.463 +} {}
1.464 +
1.465 +test basic-30.1 {Tcl_ExprLongObj} {emptyTest} {
1.466 +} {}
1.467 +
1.468 +test basic-31.1 {Tcl_ExprDoubleObj} {emptyTest} {
1.469 +} {}
1.470 +
1.471 +test basic-32.1 {Tcl_ExprBooleanObj} {emptyTest} {
1.472 +} {}
1.473 +
1.474 +test basic-33.1 {TclInvoke} {emptyTest} {
1.475 +} {}
1.476 +
1.477 +test basic-34.1 {TclGlobalInvoke} {emptyTest} {
1.478 +} {}
1.479 +
1.480 +test basic-35.1 {TclObjInvokeGlobal} {emptyTest} {
1.481 +} {}
1.482 +
1.483 +test basic-36.1 {TclObjInvoke, lookup of "unknown" command} {
1.484 + catch {eval namespace delete [namespace children :: test_ns_*]}
1.485 + catch {interp delete test_interp}
1.486 + interp create test_interp
1.487 + interp eval test_interp {
1.488 + proc unknown {args} {
1.489 + return "global unknown"
1.490 + }
1.491 + namespace eval test_ns_basic {
1.492 + proc unknown {args} {
1.493 + return "namespace unknown"
1.494 + }
1.495 + }
1.496 + }
1.497 + list [interp alias test_interp newAlias test_interp doesntExist] \
1.498 + [catch {interp eval test_interp {newAlias}} msg] $msg \
1.499 + [interp delete test_interp]
1.500 +} {newAlias 0 {global unknown} {}}
1.501 +
1.502 +test basic-37.1 {Tcl_ExprString: see expr.test} {emptyTest} {
1.503 +} {}
1.504 +
1.505 +test basic-38.1 {Tcl_ExprObj} {emptyTest} {
1.506 +} {}
1.507 +
1.508 +test basic-39.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
1.509 + testcmdtrace tracetest {set stuff [expr 14 + 16]}
1.510 +} {{expr 14 + 16} {expr 14 + 16} {set stuff [expr 14 + 16]} {set stuff 30}}
1.511 +test basic-39.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
1.512 + testcmdtrace tracetest {set stuff [info tclversion]}
1.513 +} [list {info tclversion} {info tclversion} {set stuff [info tclversion]} "set stuff $tclvers"]
1.514 +test basic-39.3 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
1.515 + testcmdtrace deletetest {set stuff [info tclversion]}
1.516 +} $tclvers
1.517 +test basic-39.4 {Tcl_CreateTrace, check that tracing doesn't cause memory faults} {testcmdtrace} {
1.518 + # Note that the proc call is the same as the variable name, and that
1.519 + # the call can be direct or indirect by way of another procedure
1.520 + proc tracer {args} {}
1.521 + proc tracedLoop {level} {
1.522 + incr level
1.523 + tracer
1.524 + foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}
1.525 + }
1.526 + testcmdtrace tracetest {tracedLoop 0}
1.527 +} {{tracedLoop 0} {tracedLoop 0} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {1 2} {tracedLoop $level}} {tracedLoop $level} {tracedLoop 1} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {} {tracedLoop $level}} {tracedLoop $level} {tracedLoop 1} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {} {tracedLoop $level}}}
1.528 +catch {rename tracer {}}
1.529 +catch {rename tracedLoop {}}
1.530 +
1.531 +test basic-39.5 {Tcl_CreateObjTrace, status return TCL_ERROR} {testcmdtrace} {
1.532 + proc Error { args } { error "Shouldn't get here" }
1.533 + set x 1;
1.534 + list [catch {testcmdtrace resulttest {Error $x}} result] [set result]
1.535 +} {1 {Error $x}}
1.536 +
1.537 +test basic-39.6 {Tcl_CreateObjTrace, status return TCL_RETURN} {testcmdtrace} {
1.538 + proc Return { args } { error "Shouldn't get here" }
1.539 + set x 1;
1.540 + list [catch {testcmdtrace resulttest {Return $x}} result] [set result]
1.541 +} {2 {}}
1.542 +
1.543 +test basic-39.7 {Tcl_CreateObjTrace, status return TCL_BREAK} {testcmdtrace} {
1.544 + proc Break { args } { error "Shouldn't get here" }
1.545 + set x 1;
1.546 + list [catch {testcmdtrace resulttest {Break $x}} result] [set result]
1.547 +} {3 {}}
1.548 +
1.549 +test basic-39.8 {Tcl_CreateObjTrace, status return TCL_CONTINUE} {testcmdtrace} {
1.550 + proc Continue { args } { error "Shouldn't get here" }
1.551 + set x 1;
1.552 + list [catch {testcmdtrace resulttest {Continue $x}} result] [set result]
1.553 +} {4 {}}
1.554 +
1.555 +test basic-39.9 {Tcl_CreateObjTrace, status return unknown} {testcmdtrace} {
1.556 + proc OtherStatus { args } { error "Shouldn't get here" }
1.557 + set x 1;
1.558 + list [catch {testcmdtrace resulttest {OtherStatus $x}} result] [set result]
1.559 +} {6 {}}
1.560 +
1.561 +test basic-39.10 {Tcl_CreateTrace, correct level interpretation} {testcmdtrace} {
1.562 + proc foo {} {uplevel 1 bar}
1.563 + proc bar {} {uplevel 1 grok}
1.564 + proc grok {} {uplevel 1 spock}
1.565 + proc spock {} {uplevel 1 fascinating}
1.566 + proc fascinating {} {}
1.567 + testcmdtrace leveltest {foo}
1.568 +} {foo {foo} {uplevel 1 bar} {uplevel 1 bar} bar {bar} {uplevel 1 grok} {uplevel 1 grok}}
1.569 +
1.570 +test basic-40.1 {Tcl_DeleteTrace} {emptyTest} {
1.571 + # the above tests have tested Tcl_DeleteTrace
1.572 +} {}
1.573 +
1.574 +test basic-41.1 {Tcl_AddErrorInfo} {emptyTest} {
1.575 +} {}
1.576 +
1.577 +test basic-42.1 {Tcl_AddObjErrorInfo} {emptyTest} {
1.578 +} {}
1.579 +
1.580 +test basic-43.1 {Tcl_VarEval} {emptyTest} {
1.581 +} {}
1.582 +
1.583 +test basic-44.1 {Tcl_GlobalEval} {emptyTest} {
1.584 +} {}
1.585 +
1.586 +test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {emptyTest} {
1.587 +} {}
1.588 +
1.589 +test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} {
1.590 + catch {close $f}
1.591 + set res [catch {
1.592 + set f [open |[list [interpreter]] w+]
1.593 + fconfigure $f -buffering line
1.594 + puts $f {fconfigure stdout -buffering line}
1.595 + puts $f continue
1.596 + puts $f {puts $errorInfo}
1.597 + puts $f {puts DONE}
1.598 + set newMsg {}
1.599 + set msg {}
1.600 + while {$newMsg != "DONE"} {
1.601 + set newMsg [gets $f]
1.602 + append msg "${newMsg}\n"
1.603 + }
1.604 + close $f
1.605 + } error]
1.606 + list $res $msg
1.607 +} {1 {invoked "continue" outside of a loop
1.608 + while executing
1.609 +"continue"
1.610 +DONE
1.611 +}}
1.612 +
1.613 +test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} -setup {
1.614 + set fName [makeFile {
1.615 + puts hello
1.616 + break
1.617 + } BREAKtest]
1.618 +} -constraints {
1.619 + exec
1.620 +} -body {
1.621 + exec [interpreter] $fName
1.622 +} -cleanup {
1.623 + removeFile BREAKtest
1.624 +} -returnCodes error -match glob -result {hello
1.625 +invoked "break" outside of a loop
1.626 + while executing
1.627 +"break"
1.628 + (file "*BREAKtest" line 3)}
1.629 +
1.630 +test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} -setup {
1.631 + set fName [makeFile {
1.632 + interp alias {} patch {} info patchlevel
1.633 + patch
1.634 + break
1.635 + } BREAKtest]
1.636 +} -constraints {
1.637 + exec
1.638 +} -body {
1.639 + exec [interpreter] $fName
1.640 +} -cleanup {
1.641 + removeFile BREAKtest
1.642 +} -returnCodes error -match glob -result {invoked "break" outside of a loop
1.643 + while executing
1.644 +"break"
1.645 + (file "*BREAKtest" line 4)}
1.646 +
1.647 +test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} -setup {
1.648 + set fName [makeFile {
1.649 + foo [set a 1] [break]
1.650 + } BREAKtest]
1.651 +} -constraints {
1.652 + exec
1.653 +} -body {
1.654 + exec [interpreter] $fName
1.655 +} -cleanup {
1.656 + removeFile BREAKtest
1.657 +} -returnCodes error -match glob -result {invoked "break" outside of a loop
1.658 + while executing*
1.659 +"foo \[set a 1] \[break]"
1.660 + (file "*BREAKtest" line 2)}
1.661 +
1.662 +test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} -setup {
1.663 + set fName [makeFile {
1.664 + return -code return
1.665 + } BREAKtest]
1.666 +} -constraints {
1.667 + exec
1.668 +} -body {
1.669 + exec [interpreter] $fName
1.670 +} -cleanup {
1.671 + removeFile BREAKtest
1.672 +} -returnCodes error -match glob -result {command returned bad code: 2
1.673 + while executing
1.674 +"return -code return"
1.675 + (file "*BREAKtest" line 2)}
1.676 +
1.677 +test basic-47.1 {Tcl_EvalEx: check for missing close-bracket} -body {
1.678 + subst {a[set b [format cd]}
1.679 +} -returnCodes error -result {missing close-bracket}
1.680 +
1.681 +test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
1.682 + set ::x global
1.683 + namespace eval ns {
1.684 + variable x namespace
1.685 + testevalex {set x changed} global
1.686 + set ::result [list $::x $x]
1.687 + }
1.688 + namespace delete ns
1.689 + set ::result
1.690 +} {changed namespace}
1.691 +test basic-49.2 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
1.692 + set ::x global
1.693 + namespace eval ns {
1.694 + variable x namespace
1.695 + testevalex {set ::context $x} global
1.696 + }
1.697 + namespace delete ns
1.698 + set ::context
1.699 +} {global}
1.700 +
1.701 +# cleanup
1.702 +catch {eval namespace delete [namespace children :: test_ns_*]}
1.703 +catch {namespace delete george}
1.704 +catch {interp delete test_interp}
1.705 +catch {rename p ""}
1.706 +catch {rename q ""}
1.707 +catch {rename cmd ""}
1.708 +catch {rename value:at: ""}
1.709 +catch {unset x}
1.710 +::tcltest::cleanupTests
1.711 +return