1# This file contains tests for the tclBasic.c source file. Tests appear in 2# the same order as the C code that they test. The set of tests is 3# currently incomplete since it currently includes only new tests for 4# code changed for the addition of Tcl namespaces. Other variable- 5# related tests appear in several other test files including 6# assocd.test, cmdInfo.test, eval.test, expr.test, interp.test, 7# and trace.test. 8# 9# Sourcing this file into Tcl runs the tests and generates output for 10# errors. No output means no errors were found. 11# 12# Copyright (c) 1997 Sun Microsystems, Inc. 13# Copyright (c) 1998-1999 by Scriptics Corporation. 14# 15# See the file "license.terms" for information on usage and redistribution 16# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 17# 18# RCS: @(#) $Id: basic.test,v 1.25.2.8 2007/06/27 17:29:24 dgp Exp $ 19# 20 21package require tcltest 2 22namespace import -force ::tcltest::* 23 24testConstraint testcmdtoken [llength [info commands testcmdtoken]] 25testConstraint testcmdtrace [llength [info commands testcmdtrace]] 26testConstraint testcreatecommand [llength [info commands testcreatecommand]] 27testConstraint testevalex [llength [info commands testevalex]] 28testConstraint exec [llength [info commands exec]] 29 30# This variable needs to be changed when the major or minor version number for 31# Tcl changes. 32set tclvers 8.4 33 34catch {namespace delete test_ns_basic} 35catch {interp delete test_interp} 36catch {rename p ""} 37catch {rename q ""} 38catch {rename cmd ""} 39catch {unset x} 40 41test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} { 42 catch {interp delete test_interp} 43 interp create test_interp 44 interp eval test_interp { 45 namespace eval test_ns_basic { 46 proc p {} { 47 return [namespace current] 48 } 49 } 50 } 51 list [interp eval test_interp {test_ns_basic::p}] \ 52 [interp delete test_interp] 53} {::test_ns_basic {}} 54 55test basic-2.1 {TclHideUnsafeCommands} {emptyTest} { 56} {} 57 58test basic-3.1 {Tcl_CallWhenDeleted: see dcall.test} {emptyTest} { 59} {} 60 61test basic-4.1 {Tcl_DontCallWhenDeleted: see dcall.test} {emptyTest} { 62} {} 63 64test basic-5.1 {Tcl_SetAssocData: see assoc.test} {emptyTest} { 65} {} 66 67test basic-6.1 {Tcl_DeleteAssocData: see assoc.test} {emptyTest} { 68} {} 69 70test basic-7.1 {Tcl_GetAssocData: see assoc.test} {emptyTest} { 71} {} 72 73test basic-8.1 {Tcl_InterpDeleted} {emptyTest} { 74} {} 75 76test basic-9.1 {Tcl_DeleteInterp: see interp.test} {emptyTest} { 77} {} 78 79test basic-10.1 {DeleteInterpProc, destroys interp's global namespace} { 80 catch {interp delete test_interp} 81 interp create test_interp 82 interp eval test_interp { 83 namespace eval test_ns_basic { 84 namespace export p 85 proc p {} { 86 return [namespace current] 87 } 88 } 89 namespace eval test_ns_2 { 90 namespace import ::test_ns_basic::p 91 variable v 27 92 proc q {} { 93 variable v 94 return "[p] $v" 95 } 96 } 97 } 98 list [interp eval test_interp {test_ns_2::q}] \ 99 [interp eval test_interp {namespace delete ::}] \ 100 [catch {interp eval test_interp {set a 123}} msg] $msg \ 101 [interp delete test_interp] 102} {{::test_ns_basic 27} {} 1 {invalid command name "set"} {}} 103 104test basic-11.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden cmd} { 105 catch {interp delete test_interp} 106 interp create test_interp 107 interp eval test_interp { 108 proc p {} { 109 return 27 110 } 111 } 112 interp alias {} localP test_interp p 113 list [interp eval test_interp {p}] \ 114 [localP] \ 115 [test_interp hide p] \ 116 [catch {localP} msg] $msg \ 117 [interp delete test_interp] \ 118 [catch {localP} msg] $msg 119} {27 27 {} 1 {invalid command name "p"} {} 1 {invalid command name "localP"}} 120 121# NB: More tests about hide/expose are found in interp.test 122 123test basic-12.1 {Tcl_HideCommand, names of hidden cmds can't have namespace qualifiers} { 124 catch {interp delete test_interp} 125 interp create test_interp 126 interp eval test_interp { 127 namespace eval test_ns_basic { 128 proc p {} { 129 return [namespace current] 130 } 131 } 132 } 133 list [catch {test_interp hide test_ns_basic::p x} msg] $msg \ 134 [catch {test_interp hide x test_ns_basic::p} msg1] $msg1 \ 135 [interp delete test_interp] 136} {1 {can only hide global namespace commands (use rename then hide)} 1 {cannot use namespace qualifiers in hidden command token (rename)} {}} 137 138test basic-12.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace} { 139 catch {namespace delete test_ns_basic} 140 catch {rename cmd ""} 141 proc cmd {} { ;# note that this is global 142 return [namespace current] 143 } 144 namespace eval test_ns_basic { 145 proc hideCmd {} { 146 interp hide {} cmd 147 } 148 proc exposeCmd {} { 149 interp expose {} cmd 150 } 151 proc callCmd {} { 152 cmd 153 } 154 } 155 list [test_ns_basic::callCmd] \ 156 [test_ns_basic::hideCmd] \ 157 [catch {cmd} msg] $msg \ 158 [test_ns_basic::exposeCmd] \ 159 [test_ns_basic::callCmd] \ 160 [namespace delete test_ns_basic] 161} {:: {} 1 {invalid command name "cmd"} {} :: {}} 162 163test basic-13.1 {Tcl_ExposeCommand, a command stays in the global namespace and can not go to another namespace} { 164 catch {namespace delete test_ns_basic} 165 catch {rename cmd ""} 166 proc cmd {} { ;# note that this is global 167 return [namespace current] 168 } 169 namespace eval test_ns_basic { 170 proc hideCmd {} { 171 interp hide {} cmd 172 } 173 proc exposeCmdFailing {} { 174 interp expose {} cmd ::test_ns_basic::newCmd 175 } 176 proc exposeCmdWorkAround {} { 177 interp expose {} cmd; 178 rename cmd ::test_ns_basic::newCmd; 179 } 180 proc callCmd {} { 181 cmd 182 } 183 } 184 list [test_ns_basic::callCmd] \ 185 [test_ns_basic::hideCmd] \ 186 [catch {test_ns_basic::exposeCmdFailing} msg] $msg \ 187 [test_ns_basic::exposeCmdWorkAround] \ 188 [test_ns_basic::newCmd] \ 189 [namespace delete test_ns_basic] 190} {:: {} 1 {can not expose to a namespace (use expose to toplevel, then rename)} {} ::test_ns_basic {}} 191test basic-13.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being exposed} { 192 catch {rename p ""} 193 catch {rename cmd ""} 194 proc p {} { 195 cmd 196 } 197 proc cmd {} { 198 return 42 199 } 200 list [p] \ 201 [interp hide {} cmd] \ 202 [proc cmd {} {return Hello}] \ 203 [cmd] \ 204 [rename cmd ""] \ 205 [interp expose {} cmd] \ 206 [p] 207} {42 {} {} Hello {} {} 42} 208 209test basic-14.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} {testcreatecommand} { 210 catch {eval namespace delete [namespace children :: test_ns_*]} 211 list [testcreatecommand create] \ 212 [test_ns_basic::createdcommand] \ 213 [testcreatecommand delete] 214} {{} {CreatedCommandProc in ::test_ns_basic} {}} 215test basic-14.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} {testcreatecommand} { 216 catch {eval namespace delete [namespace children :: test_ns_*]} 217 catch {rename value:at: ""} 218 list [testcreatecommand create2] \ 219 [value:at:] \ 220 [testcreatecommand delete2] 221} {{} {CreatedCommandProc2 in ::} {}} 222 223test basic-15.1 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} { 224 catch {eval namespace delete [namespace children :: test_ns_*]} 225 namespace eval test_ns_basic {} 226 proc test_ns_basic::cmd {} { ;# proc requires that ns already exist 227 return [namespace current] 228 } 229 list [test_ns_basic::cmd] \ 230 [namespace delete test_ns_basic] 231} {::test_ns_basic {}} 232 233test basic-16.1 {TclInvokeStringCommand} {emptyTest} { 234} {} 235 236test basic-17.1 {TclInvokeObjCommand} {emptyTest} { 237} {} 238 239test basic-18.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} { 240 catch {eval namespace delete [namespace children :: test_ns_*]} 241 catch {rename cmd ""} 242 namespace eval test_ns_basic { 243 proc p {} { 244 return "p in [namespace current]" 245 } 246 } 247 list [test_ns_basic::p] \ 248 [rename test_ns_basic::p test_ns_basic::q] \ 249 [test_ns_basic::q] 250} {{p in ::test_ns_basic} {} {p in ::test_ns_basic}} 251test basic-18.2 {TclRenameCommand, existing cmd must be found} { 252 catch {eval namespace delete [namespace children :: test_ns_*]} 253 list [catch {rename test_ns_basic::p test_ns_basic::q} msg] $msg 254} {1 {can't rename "test_ns_basic::p": command doesn't exist}} 255test basic-18.3 {TclRenameCommand, delete cmd if new name is empty} { 256 catch {eval namespace delete [namespace children :: test_ns_*]} 257 namespace eval test_ns_basic { 258 proc p {} { 259 return "p in [namespace current]" 260 } 261 } 262 list [info commands test_ns_basic::*] \ 263 [rename test_ns_basic::p ""] \ 264 [info commands test_ns_basic::*] 265} {::test_ns_basic::p {} {}} 266test basic-18.4 {TclRenameCommand, bad new name} { 267 catch {eval namespace delete [namespace children :: test_ns_*]} 268 namespace eval test_ns_basic { 269 proc p {} { 270 return "p in [namespace current]" 271 } 272 } 273 rename test_ns_basic::p :::george::martha 274} {} 275test basic-18.5 {TclRenameCommand, new name must not already exist} { 276 namespace eval test_ns_basic { 277 proc q {} { 278 return 42 279 } 280 } 281 list [catch {rename test_ns_basic::q :::george::martha} msg] $msg 282} {1 {can't rename to ":::george::martha": command already exists}} 283test basic-18.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} { 284 catch {eval namespace delete [namespace children :: test_ns_*]} 285 catch {rename p ""} 286 catch {rename q ""} 287 proc p {} { 288 return "p in [namespace current]" 289 } 290 proc q {} { 291 return "q in [namespace current]" 292 } 293 namespace eval test_ns_basic { 294 proc callP {} { 295 p 296 } 297 } 298 list [test_ns_basic::callP] \ 299 [rename q test_ns_basic::p] \ 300 [test_ns_basic::callP] 301} {{p in ::} {} {q in ::test_ns_basic}} 302 303test basic-19.1 {Tcl_SetCommandInfo} {emptyTest} { 304} {} 305 306test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {testcmdtoken} { 307 catch {eval namespace delete [namespace children :: test_ns_*]} 308 catch {rename p ""} 309 catch {rename q ""} 310 catch {unset x} 311 set x [namespace eval test_ns_basic::test_ns_basic2 { 312 # the following creates a cmd in the global namespace 313 testcmdtoken create p 314 }] 315 list [testcmdtoken name $x] \ 316 [rename ::p q] \ 317 [testcmdtoken name $x] 318} {{p ::p} {} {q ::q}} 319test basic-20.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} {testcmdtoken} { 320 catch {rename q ""} 321 set x [testcmdtoken create test_ns_basic::test_ns_basic2::p] 322 list [testcmdtoken name $x] \ 323 [rename test_ns_basic::test_ns_basic2::p q] \ 324 [testcmdtoken name $x] 325} {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}} 326 327test basic-21.1 {Tcl_GetCommandName} {emptyTest} { 328} {} 329 330test basic-22.1 {Tcl_GetCommandFullName} { 331 catch {eval namespace delete [namespace children :: test_ns_*]} 332 namespace eval test_ns_basic1 { 333 namespace export cmd* 334 proc cmd1 {} {} 335 proc cmd2 {} {} 336 } 337 namespace eval test_ns_basic2 { 338 namespace export * 339 namespace import ::test_ns_basic1::* 340 proc p {} {} 341 } 342 namespace eval test_ns_basic3 { 343 namespace import ::test_ns_basic2::* 344 proc q {} {} 345 list [namespace which -command foreach] \ 346 [namespace which -command q] \ 347 [namespace which -command p] \ 348 [namespace which -command cmd1] \ 349 [namespace which -command ::test_ns_basic2::cmd2] 350 } 351} {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2} 352 353test basic-23.1 {Tcl_DeleteCommand} {emptyTest} { 354} {} 355 356test basic-24.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} { 357 catch {interp delete test_interp} 358 catch {unset x} 359 interp create test_interp 360 interp eval test_interp { 361 proc useSet {} { 362 return [set a 123] 363 } 364 } 365 set x [interp eval test_interp {useSet}] 366 interp eval test_interp { 367 rename set "" 368 proc set {args} { 369 return "set called with $args" 370 } 371 } 372 list $x \ 373 [interp eval test_interp {useSet}] \ 374 [interp delete test_interp] 375} {123 {set called with a 123} {}} 376test basic-24.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} { 377 catch {eval namespace delete [namespace children :: test_ns_*]} 378 catch {rename p ""} 379 proc p {} { 380 return "global p" 381 } 382 namespace eval test_ns_basic { 383 proc p {} { 384 return "namespace p" 385 } 386 proc callP {} { 387 p 388 } 389 } 390 list [test_ns_basic::callP] \ 391 [rename test_ns_basic::p ""] \ 392 [test_ns_basic::callP] 393} {{namespace p} {} {global p}} 394test basic-24.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to a deleted cmd} { 395 catch {eval namespace delete [namespace children :: test_ns_*]} 396 catch {rename p ""} 397 namespace eval test_ns_basic { 398 namespace export p 399 proc p {} {return 42} 400 } 401 namespace eval test_ns_basic2 { 402 namespace import ::test_ns_basic::* 403 proc callP {} { 404 p 405 } 406 } 407 list [test_ns_basic2::callP] \ 408 [info commands test_ns_basic2::*] \ 409 [rename test_ns_basic::p ""] \ 410 [catch {test_ns_basic2::callP} msg] $msg \ 411 [info commands test_ns_basic2::*] 412} {42 {::test_ns_basic2::callP ::test_ns_basic2::p} {} 1 {invalid command name "p"} ::test_ns_basic2::callP} 413 414test basic-25.1 {TclCleanupCommand} {emptyTest} { 415} {} 416 417test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} { 418 # If object isn't preserved, errorInfo would be set to 419 # "foo\n while executing\n\"garbage bytes\"" because the object's 420 # string would have been freed, leaving garbage bytes for the error 421 # message. 422 423 proc bgerror {args} {set ::x $::errorInfo} 424 set fName [makeFile {} test1] 425 set f [open $fName w] 426 fileevent $f writable "fileevent $f writable {}; error foo" 427 set x {} 428 vwait x 429 close $f 430 removeFile test1 431 rename bgerror {} 432 set x 433} "foo\n while executing\n\"error foo\"" 434 435test basic-26.2 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} { 436 # 437 # Follow the pure-list branch in a manner that 438 # a - the pure-list internal rep is destroyed by shimmering 439 # b - the command returns an error 440 # As the error code in Tcl_EvalObjv accesses the list elements, this will 441 # cause a segfault if [Bug 1119369] has not been fixed. 442 # 443 444 set SRC [list foo 1] ;# pure-list command 445 proc foo str { 446 # Shimmer pure-list to cmdName, cleanup and error 447 proc $::SRC {} {}; $::SRC 448 error "BAD CALL" 449 } 450 catch {eval $SRC} 451} 1 452 453test basic-27.1 {Tcl_ExprLong} {emptyTest} { 454} {} 455 456test basic-28.1 {Tcl_ExprDouble} {emptyTest} { 457} {} 458 459test basic-29.1 {Tcl_ExprBoolean} {emptyTest} { 460} {} 461 462test basic-30.1 {Tcl_ExprLongObj} {emptyTest} { 463} {} 464 465test basic-31.1 {Tcl_ExprDoubleObj} {emptyTest} { 466} {} 467 468test basic-32.1 {Tcl_ExprBooleanObj} {emptyTest} { 469} {} 470 471test basic-33.1 {TclInvoke} {emptyTest} { 472} {} 473 474test basic-34.1 {TclGlobalInvoke} {emptyTest} { 475} {} 476 477test basic-35.1 {TclObjInvokeGlobal} {emptyTest} { 478} {} 479 480test basic-36.1 {TclObjInvoke, lookup of "unknown" command} { 481 catch {eval namespace delete [namespace children :: test_ns_*]} 482 catch {interp delete test_interp} 483 interp create test_interp 484 interp eval test_interp { 485 proc unknown {args} { 486 return "global unknown" 487 } 488 namespace eval test_ns_basic { 489 proc unknown {args} { 490 return "namespace unknown" 491 } 492 } 493 } 494 list [interp alias test_interp newAlias test_interp doesntExist] \ 495 [catch {interp eval test_interp {newAlias}} msg] $msg \ 496 [interp delete test_interp] 497} {newAlias 0 {global unknown} {}} 498 499test basic-37.1 {Tcl_ExprString: see expr.test} {emptyTest} { 500} {} 501 502test basic-38.1 {Tcl_ExprObj} {emptyTest} { 503} {} 504 505test basic-39.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} { 506 testcmdtrace tracetest {set stuff [expr 14 + 16]} 507} {{expr 14 + 16} {expr 14 + 16} {set stuff [expr 14 + 16]} {set stuff 30}} 508test basic-39.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} { 509 testcmdtrace tracetest {set stuff [info tclversion]} 510} [list {info tclversion} {info tclversion} {set stuff [info tclversion]} "set stuff $tclvers"] 511test basic-39.3 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} { 512 testcmdtrace deletetest {set stuff [info tclversion]} 513} $tclvers 514test basic-39.4 {Tcl_CreateTrace, check that tracing doesn't cause memory faults} {testcmdtrace} { 515 # Note that the proc call is the same as the variable name, and that 516 # the call can be direct or indirect by way of another procedure 517 proc tracer {args} {} 518 proc tracedLoop {level} { 519 incr level 520 tracer 521 foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level} 522 } 523 testcmdtrace tracetest {tracedLoop 0} 524} {{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}}} 525catch {rename tracer {}} 526catch {rename tracedLoop {}} 527 528test basic-39.5 {Tcl_CreateObjTrace, status return TCL_ERROR} {testcmdtrace} { 529 proc Error { args } { error "Shouldn't get here" } 530 set x 1; 531 list [catch {testcmdtrace resulttest {Error $x}} result] [set result] 532} {1 {Error $x}} 533 534test basic-39.6 {Tcl_CreateObjTrace, status return TCL_RETURN} {testcmdtrace} { 535 proc Return { args } { error "Shouldn't get here" } 536 set x 1; 537 list [catch {testcmdtrace resulttest {Return $x}} result] [set result] 538} {2 {}} 539 540test basic-39.7 {Tcl_CreateObjTrace, status return TCL_BREAK} {testcmdtrace} { 541 proc Break { args } { error "Shouldn't get here" } 542 set x 1; 543 list [catch {testcmdtrace resulttest {Break $x}} result] [set result] 544} {3 {}} 545 546test basic-39.8 {Tcl_CreateObjTrace, status return TCL_CONTINUE} {testcmdtrace} { 547 proc Continue { args } { error "Shouldn't get here" } 548 set x 1; 549 list [catch {testcmdtrace resulttest {Continue $x}} result] [set result] 550} {4 {}} 551 552test basic-39.9 {Tcl_CreateObjTrace, status return unknown} {testcmdtrace} { 553 proc OtherStatus { args } { error "Shouldn't get here" } 554 set x 1; 555 list [catch {testcmdtrace resulttest {OtherStatus $x}} result] [set result] 556} {6 {}} 557 558test basic-39.10 {Tcl_CreateTrace, correct level interpretation} {testcmdtrace} { 559 proc foo {} {uplevel 1 bar} 560 proc bar {} {uplevel 1 grok} 561 proc grok {} {uplevel 1 spock} 562 proc spock {} {uplevel 1 fascinating} 563 proc fascinating {} {} 564 testcmdtrace leveltest {foo} 565} {foo {foo} {uplevel 1 bar} {uplevel 1 bar} bar {bar} {uplevel 1 grok} {uplevel 1 grok}} 566 567test basic-39.11 {Tcl_CreateTrace, multiple traces} {testcmdtrace} { 568 testcmdtrace doubletest {format xx} 569} {{format xx} {format xx}} 570 571test basic-40.1 {Tcl_DeleteTrace} {emptyTest} { 572 # the above tests have tested Tcl_DeleteTrace 573} {} 574 575test basic-41.1 {Tcl_AddErrorInfo} {emptyTest} { 576} {} 577 578test basic-42.1 {Tcl_AddObjErrorInfo} {emptyTest} { 579} {} 580 581test basic-43.1 {Tcl_VarEval} {emptyTest} { 582} {} 583 584test basic-44.1 {Tcl_GlobalEval} {emptyTest} { 585} {} 586 587test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {emptyTest} { 588} {} 589 590test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} { 591 catch {close $f} 592 set res [catch { 593 set f [open |[list [interpreter]] w+] 594 fconfigure $f -buffering line 595 puts $f {fconfigure stdout -buffering line} 596 puts $f continue 597 puts $f {puts $errorInfo} 598 puts $f {puts DONE} 599 set newMsg {} 600 set msg {} 601 while {$newMsg != "DONE"} { 602 set newMsg [gets $f] 603 append msg "${newMsg}\n" 604 } 605 close $f 606 } error] 607 list $res $msg 608} {1 {invoked "continue" outside of a loop 609 while executing 610"continue" 611DONE 612}} 613 614test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} -setup { 615 set fName [makeFile { 616 puts hello 617 break 618 } BREAKtest] 619} -constraints { 620 exec 621} -body { 622 exec [interpreter] $fName 623} -cleanup { 624 removeFile BREAKtest 625} -returnCodes error -match glob -result {hello 626invoked "break" outside of a loop 627 while executing 628"break" 629 (file "*BREAKtest" line 3)} 630 631test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} -setup { 632 set fName [makeFile { 633 interp alias {} patch {} info patchlevel 634 patch 635 break 636 } BREAKtest] 637} -constraints { 638 exec 639} -body { 640 exec [interpreter] $fName 641} -cleanup { 642 removeFile BREAKtest 643} -returnCodes error -match glob -result {invoked "break" outside of a loop 644 while executing 645"break" 646 (file "*BREAKtest" line 4)} 647 648test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} -setup { 649 set fName [makeFile { 650 foo [set a 1] [break] 651 } BREAKtest] 652} -constraints { 653 exec 654} -body { 655 exec [interpreter] $fName 656} -cleanup { 657 removeFile BREAKtest 658} -returnCodes error -match glob -result {invoked "break" outside of a loop 659 while executing* 660"foo \[set a 1] \[break]" 661 (file "*BREAKtest" line 2)} 662 663test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} -setup { 664 set fName [makeFile { 665 return -code return 666 } BREAKtest] 667} -constraints { 668 exec 669} -body { 670 exec [interpreter] $fName 671} -cleanup { 672 removeFile BREAKtest 673} -returnCodes error -match glob -result {command returned bad code: 2 674 while executing 675"return -code return" 676 (file "*BREAKtest" line 2)} 677 678test basic-47.1 {Tcl_EvalEx: check for missing close-bracket} -body { 679 subst {a[set b [format cd]} 680} -returnCodes error -result {missing close-bracket} 681 682test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex { 683 set ::x global 684 namespace eval ns { 685 variable x namespace 686 testevalex {set x changed} global 687 set ::result [list $::x $x] 688 } 689 namespace delete ns 690 set ::result 691} {changed namespace} 692test basic-49.2 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex { 693 set ::x global 694 namespace eval ns { 695 variable x namespace 696 testevalex {set ::context $x} global 697 } 698 namespace delete ns 699 set ::context 700} {global} 701 702# cleanup 703catch {eval namespace delete [namespace children :: test_ns_*]} 704catch {namespace delete george} 705catch {interp delete test_interp} 706catch {rename p ""} 707catch {rename q ""} 708catch {rename cmd ""} 709catch {rename value:at: ""} 710catch {unset x} 711::tcltest::cleanupTests 712return 713