1# This file tests the multiple interpreter facility of Tcl 2# 3# This file contains a collection of tests for one or more of the Tcl 4# built-in commands. Sourcing this file into Tcl runs the tests and 5# generates output for errors. No output means no errors were found. 6# 7# Copyright © 1995-1996 Sun Microsystems, Inc. 8# Copyright © 1998-1999 Scriptics Corporation. 9# 10# See the file "license.terms" for information on usage and redistribution 11# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 12 13if {"::tcltest" ni [namespace children]} { 14 package require tcltest 2.5 15 namespace import -force ::tcltest::* 16} 17 18::tcltest::loadTestedCommands 19catch [list package require -exact tcl::test [info patchlevel]] 20 21testConstraint testinterpdelete [llength [info commands testinterpdelete]] 22 23set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs tcl:encoding:system tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempdir tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable tcl:info:cmdtype tcl:info:nameofexecutable tcl:process:autopurge tcl:process:list tcl:process:purge tcl:process:status tcl:zipfs:lmkimg tcl:zipfs:lmkzip tcl:zipfs:mkimg tcl:zipfs:mkkey tcl:zipfs:mkzip tcl:zipfs:mount tcl:zipfs:mount_data tcl:zipfs:unmount unload} 24 25foreach i [interp children] { 26 interp delete $i 27} 28 29# Part 0: Check out options for interp command 30test interp-1.1 {options for interp command} -returnCodes error -body { 31 interp 32} -result {wrong # args: should be "interp cmd ?arg ...?"} 33test interp-1.2 {options for interp command} -returnCodes error -body { 34 interp frobox 35} -result {bad option "frobox": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} 36test interp-1.3 {options for interp command} { 37 interp delete 38} "" 39test interp-1.4 {options for interp command} -returnCodes error -body { 40 interp delete foo bar 41} -result {could not find interpreter "foo"} 42test interp-1.5 {options for interp command} -returnCodes error -body { 43 interp exists foo bar 44} -result {wrong # args: should be "interp exists ?path?"} 45# 46# test interp-0.6 was removed 47# 48test interp-1.6 {options for interp command} -returnCodes error -body { 49 interp children foo bar zop 50} -result {wrong # args: should be "interp children ?path?"} 51test interp-1.7 {options for interp command} -returnCodes error -body { 52 interp hello 53} -result {bad option "hello": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} 54test interp-1.8 {options for interp command} -returnCodes error -body { 55 interp -froboz 56} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} 57test interp-1.9 {options for interp command} -returnCodes error -body { 58 interp -froboz -safe 59} -result {bad option "-froboz": must be alias, aliases, bgerror, cancel, children, create, debug, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, limit, marktrusted, recursionlimit, share, target, or transfer} 60test interp-1.10 {options for interp command} -returnCodes error -body { 61 interp target 62} -result {wrong # args: should be "interp target path alias"} 63 64# Part 1: Basic interpreter creation tests: 65test interp-2.1 {basic interpreter creation} { 66 interp create a 67} a 68test interp-2.2 {basic interpreter creation} { 69 catch {interp create} 70} 0 71test interp-2.3 {basic interpreter creation} { 72 catch {interp create -safe} 73} 0 74test interp-2.4 {basic interpreter creation} -setup { 75 catch {interp create a} 76} -returnCodes error -body { 77 interp create a 78} -result {interpreter named "a" already exists, cannot create} 79test interp-2.5 {basic interpreter creation} { 80 interp create b -safe 81} b 82test interp-2.6 {basic interpreter creation} { 83 interp create d -safe 84} d 85test interp-2.7 {basic interpreter creation} { 86 list [catch {interp create -froboz} msg] $msg 87} {1 {bad option "-froboz": must be -safe or --}} 88test interp-2.8 {basic interpreter creation} { 89 interp create -- -froboz 90} -froboz 91test interp-2.9 {basic interpreter creation} { 92 interp create -safe -- -froboz1 93} -froboz1 94test interp-2.10 {basic interpreter creation} -setup { 95 catch {interp create a} 96} -body { 97 interp create {a x1} 98 interp create {a x2} 99 interp create {a x3} -safe 100} -result {a x3} 101test interp-2.11 {anonymous interps vs existing procs} { 102 set x [interp create] 103 regexp "interp(\[0-9]+)" $x dummy thenum 104 interp delete $x 105 proc interp$thenum {} {} 106 set x [interp create] 107 regexp "interp(\[0-9]+)" $x dummy anothernum 108 expr {$anothernum > $thenum} 109} 1 110test interp-2.12 {anonymous interps vs existing procs} { 111 set x [interp create -safe] 112 regexp "interp(\[0-9]+)" $x dummy thenum 113 interp delete $x 114 proc interp$thenum {} {} 115 set x [interp create -safe] 116 regexp "interp(\[0-9]+)" $x dummy anothernum 117 expr {$anothernum - $thenum} 118} 1 119test interp-2.13 {correct default when no $path arg is given} -body { 120 interp create -- 121} -match regexp -result {interp[0-9]+} 122 123foreach i [interp children] { 124 interp delete $i 125} 126 127# Part 2: Testing "interp children" and "interp exists" 128test interp-3.1 {testing interp exists and interp children} { 129 interp children 130} "" 131test interp-3.2 {testing interp exists and interp children} { 132 interp create a 133 interp exists a 134} 1 135test interp-3.3 {testing interp exists and interp children} { 136 interp exists nonexistent 137} 0 138test interp-3.4 {testing interp exists and interp children} -body { 139 interp children a b c 140} -returnCodes error -result {wrong # args: should be "interp children ?path?"} 141test interp-3.5 {testing interp exists and interp children} -body { 142 interp exists a b c 143} -returnCodes error -result {wrong # args: should be "interp exists ?path?"} 144test interp-3.6 {testing interp exists and interp children} { 145 interp exists 146} 1 147test interp-3.7 {testing interp exists and interp children} -setup { 148 catch {interp create a} 149} -body { 150 interp children 151} -result a 152test interp-3.8 {testing interp exists and interp children} -body { 153 interp children a b c 154} -returnCodes error -result {wrong # args: should be "interp children ?path?"} 155test interp-3.9 {testing interp exists and interp children} -setup { 156 catch {interp create a} 157} -body { 158 interp create {a a2} -safe 159 expr {"a2" in [interp children a]} 160} -result 1 161test interp-3.10 {testing interp exists and interp children} -setup { 162 catch {interp create a} 163 catch {interp create {a a2}} 164} -body { 165 interp exists {a a2} 166} -result 1 167 168# Part 3: Testing "interp delete" 169test interp-3.11 {testing interp delete} { 170 interp delete 171} "" 172test interp-4.1 {testing interp delete} { 173 catch {interp create a} 174 interp delete a 175} "" 176test interp-4.2 {testing interp delete} -returnCodes error -body { 177 interp delete nonexistent 178} -result {could not find interpreter "nonexistent"} 179test interp-4.3 {testing interp delete} -returnCodes error -body { 180 interp delete x y z 181} -result {could not find interpreter "x"} 182test interp-4.4 {testing interp delete} { 183 interp delete 184} "" 185test interp-4.5 {testing interp delete} { 186 interp create a 187 interp create {a x1} 188 interp delete {a x1} 189 expr {"x1" in [interp children a]} 190} 0 191test interp-4.6 {testing interp delete} { 192 interp create c1 193 interp create c2 194 interp create c3 195 interp delete c1 c2 c3 196} "" 197test interp-4.7 {testing interp delete} -returnCodes error -body { 198 interp create c1 199 interp create c2 200 interp delete c1 c2 c3 201} -result {could not find interpreter "c3"} 202test interp-4.8 {testing interp delete} -returnCodes error -body { 203 interp delete {} 204} -result {cannot delete the current interpreter} 205 206foreach i [interp children] { 207 interp delete $i 208} 209 210# Part 4: Consistency checking - all nondeleted interpreters should be 211# there: 212test interp-5.1 {testing consistency} { 213 interp children 214} "" 215test interp-5.2 {testing consistency} { 216 interp exists a 217} 0 218test interp-5.3 {testing consistency} { 219 interp exists nonexistent 220} 0 221 222# Recreate interpreter "a" 223interp create a 224 225# Part 5: Testing eval in interpreter object command and with interp command 226test interp-6.1 {testing eval} { 227 a eval expr {{3 + 5}} 228} 8 229test interp-6.2 {testing eval} -returnCodes error -body { 230 a eval foo 231} -result {invalid command name "foo"} 232test interp-6.3 {testing eval} { 233 a eval {proc foo {} {expr {3 + 5}}} 234 a eval foo 235} 8 236catch {a eval {proc foo {} {expr {3 + 5}}}} 237test interp-6.4 {testing eval} { 238 interp eval a foo 239} 8 240test interp-6.5 {testing eval} { 241 interp create {a x2} 242 interp eval {a x2} {proc frob {} {expr {4 * 9}}} 243 interp eval {a x2} frob 244} 36 245catch {interp create {a x2}} 246test interp-6.6 {testing eval} -returnCodes error -body { 247 interp eval {a x2} foo 248} -result {invalid command name "foo"} 249 250# UTILITY PROCEDURE RUNNING IN PARENT INTERPRETER: 251proc in_parent {args} { 252 return [list seen in parent: $args] 253} 254 255# Part 6: Testing basic alias creation 256test interp-7.1 {testing basic alias creation} { 257 a alias foo in_parent 258} foo 259catch {a alias foo in_parent} 260test interp-7.2 {testing basic alias creation} { 261 a alias bar in_parent a1 a2 a3 262} bar 263catch {a alias bar in_parent a1 a2 a3} 264# Test 6.3 has been deleted. 265test interp-7.3 {testing basic alias creation} { 266 a alias foo 267} in_parent 268test interp-7.4 {testing basic alias creation} { 269 a alias bar 270} {in_parent a1 a2 a3} 271test interp-7.5 {testing basic alias creation} { 272 lsort [a aliases] 273} {bar foo} 274test interp-7.6 {testing basic aliases arg checking} -returnCodes error -body { 275 a aliases too many args 276} -result {wrong # args: should be "a aliases"} 277 278# Part 7: testing basic alias invocation 279test interp-8.1 {testing basic alias invocation} { 280 catch {interp create a} 281 a alias foo in_parent 282 a eval foo s1 s2 s3 283} {seen in parent: {s1 s2 s3}} 284test interp-8.2 {testing basic alias invocation} { 285 catch {interp create a} 286 a alias bar in_parent a1 a2 a3 287 a eval bar s1 s2 s3 288} {seen in parent: {a1 a2 a3 s1 s2 s3}} 289test interp-8.3 {testing basic alias invocation} -returnCodes error -body { 290 catch {interp create a} 291 a alias 292} -result {wrong # args: should be "a alias aliasName ?targetName? ?arg ...?"} 293 294# Part 8: Testing aliases for non-existent or hidden targets 295test interp-9.1 {testing aliases for non-existent targets} { 296 catch {interp create a} 297 a alias zop nonexistent-command-in-parent 298 list [catch {a eval zop} msg] $msg 299} {1 {invalid command name "nonexistent-command-in-parent"}} 300test interp-9.2 {testing aliases for non-existent targets} { 301 catch {interp create a} 302 a alias zop nonexistent-command-in-parent 303 proc nonexistent-command-in-parent {} {return i_exist!} 304 a eval zop 305} i_exist! 306test interp-9.3 {testing aliases for hidden commands} { 307 catch {interp create a} 308 a eval {proc p {} {return ENTER_A}} 309 interp alias {} p a p 310 set res {} 311 lappend res [list [catch p msg] $msg] 312 interp hide a p 313 lappend res [list [catch p msg] $msg] 314 rename p {} 315 interp delete a 316 set res 317 } {{0 ENTER_A} {1 {invalid command name "p"}}} 318test interp-9.4 {testing aliases and namespace commands} { 319 proc p {} {return GLOBAL} 320 namespace eval tst { 321 proc p {} {return NAMESPACE} 322 } 323 interp alias {} a {} p 324 set res [a] 325 lappend res [namespace eval tst a] 326 rename p {} 327 rename a {} 328 namespace delete tst 329 set res 330 } {GLOBAL GLOBAL} 331 332if {[info command nonexistent-command-in-parent] != ""} { 333 rename nonexistent-command-in-parent {} 334} 335 336# Part 9: Aliasing between interpreters 337test interp-10.1 {testing aliasing between interpreters} { 338 catch {interp delete a} 339 catch {interp delete b} 340 interp create a 341 interp create b 342 interp alias a a_alias b b_alias 1 2 3 343} a_alias 344test interp-10.2 {testing aliasing between interpreters} { 345 catch {interp delete a} 346 catch {interp delete b} 347 interp create a 348 interp create b 349 b eval {proc b_alias {args} {return [list got $args]}} 350 interp alias a a_alias b b_alias 1 2 3 351 a eval a_alias a b c 352} {got {1 2 3 a b c}} 353test interp-10.3 {testing aliasing between interpreters} { 354 catch {interp delete a} 355 catch {interp delete b} 356 interp create a 357 interp create b 358 interp alias a a_alias b b_alias 1 2 3 359 list [catch {a eval a_alias a b c} msg] $msg 360} {1 {invalid command name "b_alias"}} 361test interp-10.4 {testing aliasing between interpreters} { 362 catch {interp delete a} 363 interp create a 364 a alias a_alias puts 365 a aliases 366} a_alias 367test interp-10.5 {testing aliasing between interpreters} { 368 catch {interp delete a} 369 catch {interp delete b} 370 interp create a 371 interp create b 372 a alias a_alias puts 373 interp alias a a_del b b_del 374 interp delete b 375 a aliases 376} a_alias 377test interp-10.6 {testing aliasing between interpreters} { 378 catch {interp delete a} 379 catch {interp delete b} 380 interp create a 381 interp create b 382 interp alias a a_command b b_command a1 a2 a3 383 b alias b_command in_parent b1 b2 b3 384 a eval a_command m1 m2 m3 385} {seen in parent: {b1 b2 b3 a1 a2 a3 m1 m2 m3}} 386test interp-10.7 {testing aliases between interpreters} { 387 catch {interp delete a} 388 interp create a 389 interp alias "" foo a zoppo 390 a eval {proc zoppo {x} {list $x $x $x}} 391 set x [foo 33] 392 a eval {rename zoppo {}} 393 interp alias "" foo a {} 394 return $x 395} {33 33 33} 396 397# Part 10: Testing "interp target" 398test interp-11.1 {testing interp target} { 399 list [catch {interp target} msg] $msg 400} {1 {wrong # args: should be "interp target path alias"}} 401test interp-11.2 {testing interp target} { 402 list [catch {interp target nosuchinterpreter foo} msg] $msg 403} {1 {could not find interpreter "nosuchinterpreter"}} 404test interp-11.3 {testing interp target} { 405 catch {interp delete a} 406 interp create a 407 a alias boo no_command 408 interp target a boo 409} "" 410test interp-11.4 {testing interp target} { 411 catch {interp delete x1} 412 interp create x1 413 x1 eval interp create x2 414 x1 eval x2 eval interp create x3 415 catch {interp delete y1} 416 interp create y1 417 y1 eval interp create y2 418 y1 eval y2 eval interp create y3 419 interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand 420 interp target {x1 x2 x3} xcommand 421} {y1 y2 y3} 422test interp-11.5 {testing interp target} { 423 catch {interp delete x1} 424 interp create x1 425 interp create {x1 x2} 426 interp create {x1 x2 x3} 427 catch {interp delete y1} 428 interp create y1 429 interp create {y1 y2} 430 interp create {y1 y2 y3} 431 interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand 432 list [catch {x1 eval {interp target {x2 x3} xcommand}} msg] $msg 433} {1 {target interpreter for alias "xcommand" in path "x2 x3" is not my descendant}} 434test interp-11.6 {testing interp target} { 435 foreach a [interp aliases] { 436 rename $a {} 437 } 438 list [catch {interp target {} foo} msg] $msg 439} {1 {alias "foo" in path "" not found}} 440test interp-11.7 {testing interp target} { 441 catch {interp delete a} 442 interp create a 443 list [catch {interp target a foo} msg] $msg 444} {1 {alias "foo" in path "a" not found}} 445 446# Part 11: testing "interp issafe" 447test interp-12.1 {testing interp issafe} { 448 interp issafe 449} 0 450test interp-12.2 {testing interp issafe} { 451 catch {interp delete a} 452 interp create a 453 interp issafe a 454} 0 455test interp-12.3 {testing interp issafe} { 456 catch {interp delete a} 457 interp create a 458 interp create {a x3} -safe 459 interp issafe {a x3} 460} 1 461test interp-12.4 {testing interp issafe} { 462 catch {interp delete a} 463 interp create a 464 interp create {a x3} -safe 465 interp create {a x3 foo} 466 interp issafe {a x3 foo} 467} 1 468 469# Part 12: testing interpreter object command "issafe" sub-command 470test interp-13.1 {testing foo issafe} { 471 catch {interp delete a} 472 interp create a 473 a issafe 474} 0 475test interp-13.2 {testing foo issafe} { 476 catch {interp delete a} 477 interp create a 478 interp create {a x3} -safe 479 a eval x3 issafe 480} 1 481test interp-13.3 {testing foo issafe} { 482 catch {interp delete a} 483 interp create a 484 interp create {a x3} -safe 485 interp create {a x3 foo} 486 a eval x3 eval foo issafe 487} 1 488test interp-13.4 {testing issafe arg checking} { 489 catch {interp create a} 490 list [catch {a issafe too many args} msg] $msg 491} {1 {wrong # args: should be "a issafe"}} 492 493# part 14: testing interp aliases 494test interp-14.1 {testing interp aliases} -setup { 495 interp create abc 496} -body { 497 interp eval abc {interp aliases} 498} -cleanup { 499 interp delete abc 500} -result "" 501test interp-14.2 {testing interp aliases} { 502 catch {interp delete a} 503 interp create a 504 a alias a1 puts 505 a alias a2 puts 506 a alias a3 puts 507 lsort [interp aliases a] 508} {a1 a2 a3} 509test interp-14.3 {testing interp aliases} { 510 catch {interp delete a} 511 interp create a 512 interp create {a x3} 513 interp alias {a x3} froboz "" puts 514 interp aliases {a x3} 515} froboz 516test interp-14.4 {testing interp alias - alias over parent} { 517 # SF Bug 641195 518 catch {interp delete a} 519 interp create a 520 list [catch {interp alias "" a a eval} msg] $msg [info commands a] 521} {1 {cannot define or rename alias "a": interpreter deleted} {}} 522test interp-14.5 {testing interp-alias: wrong # args} -body { 523 proc setx x {set x} 524 interp alias {} a {} setx 525 catch {a 1 2} 526 set ::errorInfo 527} -cleanup { 528 rename setx {} 529 rename a {} 530} -result {wrong # args: should be "a x" 531 while executing 532"a 1 2"} 533test interp-14.6 {testing interp-alias: wrong # args} -setup { 534 proc setx x {set x} 535 catch {interp delete a} 536 interp create a 537} -body { 538 interp alias a a {} setx 539 catch {a eval a 1 2} 540 set ::errorInfo 541} -cleanup { 542 rename setx {} 543 interp delete a 544} -result {wrong # args: should be "a x" 545 invoked from within 546"a 1 2" 547 invoked from within 548"a eval a 1 2"} 549test interp-14.7 {testing interp-alias: wrong # args} -setup { 550 proc setx x {set x} 551 catch {interp delete a} 552 interp create a 553} -body { 554 interp alias a a {} setx 555 a eval { 556 catch {a 1 2} 557 set ::errorInfo 558 } 559} -cleanup { 560 rename setx {} 561 interp delete a 562} -result {wrong # args: should be "a x" 563 invoked from within 564"a 1 2"} 565test interp-14.8 {testing interp-alias: error messages} -body { 566 proc setx x {return -code error x} 567 interp alias {} a {} setx 568 catch {a 1} 569 set ::errorInfo 570} -cleanup { 571 rename setx {} 572 rename a {} 573} -result {x 574 while executing 575"a 1"} 576test interp-14.9 {testing interp-alias: error messages} -setup { 577 proc setx x {return -code error x} 578 catch {interp delete a} 579 interp create a 580} -body { 581 interp alias a a {} setx 582 catch {a eval a 1} 583 set ::errorInfo 584} -cleanup { 585 rename setx {} 586 interp delete a 587} -result {x 588 invoked from within 589"a 1" 590 invoked from within 591"a eval a 1"} 592test interp-14.10 {testing interp-alias: error messages} -setup { 593 proc setx x {return -code error x} 594 catch {interp delete a} 595 interp create a 596} -body { 597 interp alias a a {} setx 598 a eval { 599 catch {a 1} 600 set ::errorInfo 601 } 602} -cleanup { 603 rename setx {} 604 interp delete a 605} -result {x 606 invoked from within 607"a 1"} 608 609test interp-14.11 {{interp alias} {target named the empty string} {bug 2bf56185}} -setup { 610 set interp [interp create [info cmdcount]] 611 interp eval $interp { 612 proc {} args {return $args} 613 } 614 615} -body { 616 interp alias {} p1 $interp {} 617 p1 one two three 618} -cleanup { 619 interp delete $interp 620} -result {one two three} 621 622# part 15: testing file sharing 623test interp-15.1 {testing file sharing} { 624 catch {interp delete z} 625 interp create z 626 z eval close stdout 627 list [catch {z eval puts hello} msg] $msg 628} {1 {can not find channel named "stdout"}} 629test interp-15.2 {testing file sharing} -body { 630 catch {interp delete z} 631 interp create z 632 set f [open [makeFile {} file-15.2] w] 633 interp share "" $f z 634 z eval puts $f hello 635 z eval close $f 636 close $f 637} -cleanup { 638 removeFile file-15.2 639} -result "" 640test interp-15.3 {testing file sharing} { 641 catch {interp delete xsafe} 642 interp create xsafe -safe 643 list [catch {xsafe eval puts hello} msg] $msg 644} {1 {can not find channel named "stdout"}} 645test interp-15.4 {testing file sharing} -body { 646 catch {interp delete xsafe} 647 interp create xsafe -safe 648 set f [open [makeFile {} file-15.4] w] 649 interp share "" $f xsafe 650 xsafe eval puts $f hello 651 xsafe eval close $f 652 close $f 653} -cleanup { 654 removeFile file-15.4 655} -result "" 656test interp-15.5 {testing file sharing} { 657 catch {interp delete xsafe} 658 interp create xsafe -safe 659 interp share "" stdout xsafe 660 list [catch {xsafe eval gets stdout} msg] $msg 661} {1 {channel "stdout" wasn't opened for reading}} 662test interp-15.6 {testing file sharing} -body { 663 catch {interp delete xsafe} 664 interp create xsafe -safe 665 set f [open [makeFile {} file-15.6] w] 666 interp share "" $f xsafe 667 set x [list [catch [list xsafe eval gets $f] msg] $msg] 668 xsafe eval close $f 669 close $f 670 string compare [string tolower $x] \ 671 [list 1 [format "channel \"%s\" wasn't opened for reading" $f]] 672} -cleanup { 673 removeFile file-15.6 674} -result 0 675test interp-15.7 {testing file transferring} -body { 676 catch {interp delete xsafe} 677 interp create xsafe -safe 678 set f [open [makeFile {} file-15.7] w] 679 interp transfer "" $f xsafe 680 xsafe eval puts $f hello 681 xsafe eval close $f 682} -cleanup { 683 removeFile file-15.7 684} -result "" 685test interp-15.8 {testing file transferring} -body { 686 catch {interp delete xsafe} 687 interp create xsafe -safe 688 set f [open [makeFile {} file-15.8] w] 689 interp transfer "" $f xsafe 690 xsafe eval close $f 691 set x [list [catch {close $f} msg] $msg] 692 string compare [string tolower $x] \ 693 [list 1 [format "can not find channel named \"%s\"" $f]] 694} -cleanup { 695 removeFile file-15.8 696} -result 0 697 698# 699# Torture tests for interpreter deletion order 700# 701proc kill {} {interp delete xxx} 702test interp-16.0 {testing deletion order} { 703 catch {interp delete xxx} 704 interp create xxx 705 xxx alias kill kill 706 list [catch {xxx eval kill} msg] $msg 707} {0 {}} 708test interp-16.1 {testing deletion order} { 709 catch {interp delete xxx} 710 interp create xxx 711 interp create {xxx yyy} 712 interp alias {xxx yyy} kill "" kill 713 list [catch {interp eval {xxx yyy} kill} msg] $msg 714} {0 {}} 715test interp-16.2 {testing deletion order} { 716 catch {interp delete xxx} 717 interp create xxx 718 interp create {xxx yyy} 719 interp alias {xxx yyy} kill "" kill 720 list [catch {xxx eval yyy eval kill} msg] $msg 721} {0 {}} 722test interp-16.3 {testing deletion order} { 723 catch {interp delete xxx} 724 interp create xxx 725 interp create ddd 726 xxx alias kill kill 727 interp alias ddd kill xxx kill 728 set x [ddd eval kill] 729 interp delete ddd 730 set x 731} "" 732test interp-16.4 {testing deletion order} { 733 catch {interp delete xxx} 734 interp create xxx 735 interp create {xxx yyy} 736 interp alias {xxx yyy} kill "" kill 737 interp create ddd 738 interp alias ddd kill {xxx yyy} kill 739 set x [ddd eval kill] 740 interp delete ddd 741 set x 742} "" 743test interp-16.5 {testing deletion order, bgerror} { 744 catch {interp delete xxx} 745 interp create xxx 746 xxx eval {proc bgerror {args} {exit}} 747 xxx alias exit kill xxx 748 proc kill {i} {interp delete $i} 749 xxx eval after 100 expr {a + b} 750 after 200 751 update 752 interp exists xxx 753} 0 754 755# 756# Alias loop prevention testing. 757# 758 759test interp-17.1 {alias loop prevention} { 760 list [catch {interp alias {} a {} a} msg] $msg 761} {1 {cannot define or rename alias "a": would create a loop}} 762test interp-17.2 {alias loop prevention} { 763 catch {interp delete x} 764 interp create x 765 x alias a loop 766 list [catch {interp alias {} loop x a} msg] $msg 767} {1 {cannot define or rename alias "loop": would create a loop}} 768test interp-17.3 {alias loop prevention} { 769 catch {interp delete x} 770 interp create x 771 interp alias x a x b 772 list [catch {interp alias x b x a} msg] $msg 773} {1 {cannot define or rename alias "b": would create a loop}} 774test interp-17.4 {alias loop prevention} { 775 catch {interp delete x} 776 interp create x 777 interp alias x b x a 778 list [catch {x eval rename b a} msg] $msg 779} {1 {cannot define or rename alias "a": would create a loop}} 780test interp-17.5 {alias loop prevention} { 781 catch {interp delete x} 782 interp create x 783 x alias z l1 784 interp alias {} l2 x z 785 list [catch {rename l2 l1} msg] $msg 786} {1 {cannot define or rename alias "l1": would create a loop}} 787test interp-17.6 {alias loop prevention} { 788 catch {interp delete x} 789 interp create x 790 interp alias x a x b 791 x eval rename a c 792 list [catch {x eval rename c b} msg] $msg 793} {1 {cannot define or rename alias "b": would create a loop}} 794 795# 796# Test robustness of Tcl_DeleteInterp when applied to a child interpreter. 797# If there are bugs in the implementation these tests are likely to expose 798# the bugs as a core dump. 799# 800 801test interp-18.1 {testing Tcl_DeleteInterp vs children} testinterpdelete { 802 list [catch {testinterpdelete} msg] $msg 803} {1 {wrong # args: should be "testinterpdelete path"}} 804test interp-18.2 {testing Tcl_DeleteInterp vs children} testinterpdelete { 805 catch {interp delete a} 806 interp create a 807 testinterpdelete a 808} "" 809test interp-18.3 {testing Tcl_DeleteInterp vs children} testinterpdelete { 810 catch {interp delete a} 811 interp create a 812 interp create {a b} 813 testinterpdelete {a b} 814} "" 815test interp-18.4 {testing Tcl_DeleteInterp vs children} testinterpdelete { 816 catch {interp delete a} 817 interp create a 818 interp create {a b} 819 testinterpdelete a 820} "" 821test interp-18.5 {testing Tcl_DeleteInterp vs children} testinterpdelete { 822 catch {interp delete a} 823 interp create a 824 interp create {a b} 825 interp alias {a b} dodel {} dodel 826 proc dodel {x} {testinterpdelete $x} 827 list [catch {interp eval {a b} {dodel {a b}}} msg] $msg 828} {0 {}} 829test interp-18.6 {testing Tcl_DeleteInterp vs children} testinterpdelete { 830 catch {interp delete a} 831 interp create a 832 interp create {a b} 833 interp alias {a b} dodel {} dodel 834 proc dodel {x} {testinterpdelete $x} 835 list [catch {interp eval {a b} {dodel a}} msg] $msg 836} {0 {}} 837test interp-18.7 {eval in deleted interp} { 838 catch {interp delete a} 839 interp create a 840 a eval { 841 proc dodel {} { 842 delme 843 dosomething else 844 } 845 proc dosomething args { 846 puts "I should not have been called!!" 847 } 848 } 849 a alias delme dela 850 proc dela {} {interp delete a} 851 list [catch {a eval dodel} msg] $msg 852} {1 {attempt to call eval in deleted interpreter}} 853test interp-18.8 {eval in deleted interp} { 854 catch {interp delete a} 855 interp create a 856 a eval { 857 interp create b 858 b eval { 859 proc dodel {} { 860 dela 861 } 862 } 863 proc foo {} { 864 b eval dela 865 dosomething else 866 } 867 proc dosomething args { 868 puts "I should not have been called!!" 869 } 870 } 871 interp alias {a b} dela {} dela 872 proc dela {} {interp delete a} 873 list [catch {a eval foo} msg] $msg 874} {1 {attempt to call eval in deleted interpreter}} 875test interp-18.9 {eval in deleted interp, bug 495830} { 876 interp create tst 877 interp alias tst suicide {} interp delete tst 878 list [catch {tst eval {suicide; set a 5}} msg] $msg 879} {1 {attempt to call eval in deleted interpreter}} 880test interp-18.10 {eval in deleted interp, bug 495830} { 881 interp create tst 882 interp alias tst suicide {} interp delete tst 883 list [catch {tst eval {set set set; suicide; $set a 5}} msg] $msg 884} {1 {attempt to call eval in deleted interpreter}} 885 886# Test alias deletion 887 888test interp-19.1 {alias deletion} { 889 catch {interp delete a} 890 interp create a 891 interp alias a foo a bar 892 set s [interp alias a foo {}] 893 interp delete a 894 set s 895} {} 896test interp-19.2 {alias deletion} { 897 catch {interp delete a} 898 interp create a 899 catch {interp alias a foo {}} msg 900 interp delete a 901 set msg 902} {alias "foo" not found} 903test interp-19.3 {alias deletion} { 904 catch {interp delete a} 905 interp create a 906 interp alias a foo a bar 907 interp eval a {rename foo zop} 908 interp alias a foo a zop 909 catch {interp eval a foo} msg 910 interp delete a 911 set msg 912} {invalid command name "bar"} 913test interp-19.4 {alias deletion} { 914 catch {interp delete a} 915 interp create a 916 interp alias a foo a bar 917 interp eval a {rename foo zop} 918 catch {interp eval a foo} msg 919 interp delete a 920 set msg 921} {invalid command name "foo"} 922test interp-19.5 {alias deletion} { 923 catch {interp delete a} 924 interp create a 925 interp eval a {proc bar {} {return 1}} 926 interp alias a foo a bar 927 interp eval a {rename foo zop} 928 catch {interp eval a zop} msg 929 interp delete a 930 set msg 931} 1 932test interp-19.6 {alias deletion} { 933 catch {interp delete a} 934 interp create a 935 interp alias a foo a bar 936 interp eval a {rename foo zop} 937 interp alias a foo a zop 938 set s [interp aliases a] 939 interp delete a 940 set s 941} {::foo foo} 942test interp-19.7 {alias deletion, renaming} { 943 catch {interp delete a} 944 interp create a 945 interp alias a foo a bar 946 interp eval a rename foo blotz 947 interp alias a foo {} 948 set s [interp aliases a] 949 interp delete a 950 set s 951} {} 952test interp-19.8 {alias deletion, renaming} { 953 catch {interp delete a} 954 interp create a 955 interp alias a foo a bar 956 interp eval a rename foo blotz 957 set l "" 958 lappend l [interp aliases a] 959 interp alias a foo {} 960 lappend l [interp aliases a] 961 interp delete a 962 set l 963} {foo {}} 964test interp-19.9 {alias deletion, renaming} { 965 catch {interp delete a} 966 interp create a 967 interp alias a foo a bar 968 interp eval a rename foo blotz 969 interp eval a {proc foo {} {expr {34 * 34}}} 970 interp alias a foo {} 971 set l [interp eval a foo] 972 interp delete a 973 set l 974} 1156 975 976test interp-20.1 {interp hide, interp expose and interp invokehidden} { 977 set a [interp create] 978 $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} 979 $a eval {proc foo {} {}} 980 $a hide foo 981 catch {$a eval foo something} msg 982 interp delete $a 983 set msg 984} {invalid command name "foo"} 985test interp-20.2 {interp hide, interp expose and interp invokehidden} { 986 set a [interp create] 987 $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} 988 $a hide list 989 set l "" 990 lappend l [catch {$a eval {list 1 2 3}} msg] $msg 991 $a expose list 992 lappend l [catch {$a eval {list 1 2 3}} msg] $msg 993 interp delete $a 994 set l 995} {1 {invalid command name "list"} 0 {1 2 3}} 996test interp-20.3 {interp hide, interp expose and interp invokehidden} { 997 set a [interp create] 998 $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} 999 $a hide list 1000 set l "" 1001 lappend l [catch { $a eval {list 1 2 3} } msg] $msg 1002 lappend l [catch { $a invokehidden list 1 2 3 } msg] $msg 1003 $a expose list 1004 lappend l [catch { $a eval {list 1 2 3} } msg] $msg 1005 interp delete $a 1006 set l 1007} {1 {invalid command name "list"} 0 {1 2 3} 0 {1 2 3}} 1008test interp-20.4 {interp hide, interp expose and interp invokehidden -- passing {}} { 1009 set a [interp create] 1010 $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} 1011 $a hide list 1012 set l "" 1013 lappend l [catch { $a eval {list 1 2 3} } msg] $msg 1014 lappend l [catch { $a invokehidden list {"" 1 2 3} } msg] $msg 1015 $a expose list 1016 lappend l [catch { $a eval {list 1 2 3} } msg] $msg 1017 interp delete $a 1018 set l 1019} {1 {invalid command name "list"} 0 {{"" 1 2 3}} 0 {1 2 3}} 1020test interp-20.5 {interp hide, interp expose and interp invokehidden -- passing {}} { 1021 set a [interp create] 1022 $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} 1023 $a hide list 1024 set l "" 1025 lappend l [catch { $a eval {list 1 2 3} } msg] $msg 1026 lappend l [catch { $a invokehidden list {{} 1 2 3} } msg] $msg 1027 $a expose list 1028 lappend l [catch { $a eval {list 1 2 3} } msg] $msg 1029 interp delete $a 1030 set l 1031} {1 {invalid command name "list"} 0 {{{} 1 2 3}} 0 {1 2 3}} 1032test interp-20.6 {interp invokehidden -- eval args} { 1033 set a [interp create] 1034 $a hide list 1035 set l "" 1036 set z 45 1037 lappend l [catch { $a invokehidden list $z 1 2 3 } msg] $msg 1038 $a expose list 1039 lappend l [catch { $a eval list $z 1 2 3 } msg] $msg 1040 interp delete $a 1041 set l 1042} {0 {45 1 2 3} 0 {45 1 2 3}} 1043test interp-20.7 {interp invokehidden vs variable eval} { 1044 set a [interp create] 1045 $a hide list 1046 set z 45 1047 set l [list [catch {$a invokehidden list {$z a b c}} msg] $msg] 1048 interp delete $a 1049 set l 1050} {0 {{$z a b c}}} 1051test interp-20.8 {interp invokehidden vs variable eval} { 1052 set a [interp create] 1053 $a hide list 1054 $a eval set z 89 1055 set z 45 1056 set l [list [catch {$a invokehidden list {$z a b c}} msg] $msg] 1057 interp delete $a 1058 set l 1059} {0 {{$z a b c}}} 1060test interp-20.9 {interp invokehidden vs variable eval} { 1061 set a [interp create] 1062 $a hide list 1063 $a eval set z 89 1064 set z 45 1065 set l "" 1066 lappend l [catch {$a invokehidden list $z {$z a b c}} msg] $msg 1067 interp delete $a 1068 set l 1069} {0 {45 {$z a b c}}} 1070test interp-20.10 {interp hide, interp expose and interp invokehidden} { 1071 set a [interp create] 1072 $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} 1073 $a eval {proc foo {} {}} 1074 interp hide $a foo 1075 catch {interp eval $a foo something} msg 1076 interp delete $a 1077 set msg 1078} {invalid command name "foo"} 1079test interp-20.11 {interp hide, interp expose and interp invokehidden} { 1080 set a [interp create] 1081 $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} 1082 interp hide $a list 1083 set l "" 1084 lappend l [catch {interp eval $a {list 1 2 3}} msg] $msg 1085 interp expose $a list 1086 lappend l [catch {interp eval $a {list 1 2 3}} msg] $msg 1087 interp delete $a 1088 set l 1089} {1 {invalid command name "list"} 0 {1 2 3}} 1090test interp-20.12 {interp hide, interp expose and interp invokehidden} { 1091 set a [interp create] 1092 $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} 1093 interp hide $a list 1094 set l "" 1095 lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg 1096 lappend l [catch {interp invokehidden $a list 1 2 3} msg] $msg 1097 interp expose $a list 1098 lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg 1099 interp delete $a 1100 set l 1101} {1 {invalid command name "list"} 0 {1 2 3} 0 {1 2 3}} 1102test interp-20.13 {interp hide, interp expose, interp invokehidden -- passing {}} { 1103 set a [interp create] 1104 $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} 1105 interp hide $a list 1106 set l "" 1107 lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg 1108 lappend l [catch {interp invokehidden $a list {"" 1 2 3}} msg] $msg 1109 interp expose $a list 1110 lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg 1111 interp delete $a 1112 set l 1113} {1 {invalid command name "list"} 0 {{"" 1 2 3}} 0 {1 2 3}} 1114test interp-20.14 {interp hide, interp expose, interp invokehidden -- passing {}} { 1115 set a [interp create] 1116 $a eval {proc unknown {x args} {error "invalid command name \"$x\""}} 1117 interp hide $a list 1118 set l "" 1119 lappend l [catch {interp eval $a {list 1 2 3} } msg] $msg 1120 lappend l [catch {interp invokehidden $a list {{} 1 2 3}} msg] $msg 1121 interp expose $a list 1122 lappend l [catch {$a eval {list 1 2 3} } msg] $msg 1123 interp delete $a 1124 set l 1125} {1 {invalid command name "list"} 0 {{{} 1 2 3}} 0 {1 2 3}} 1126test interp-20.15 {interp invokehidden -- eval args} { 1127 catch {interp delete a} 1128 interp create a 1129 interp hide a list 1130 set l "" 1131 set z 45 1132 lappend l [catch {interp invokehidden a list $z 1 2 3} msg] 1133 lappend l $msg 1134 a expose list 1135 lappend l [catch {interp eval a list $z 1 2 3} msg] 1136 lappend l $msg 1137 interp delete a 1138 set l 1139} {0 {45 1 2 3} 0 {45 1 2 3}} 1140test interp-20.16 {interp invokehidden vs variable eval} { 1141 catch {interp delete a} 1142 interp create a 1143 interp hide a list 1144 set z 45 1145 set l "" 1146 lappend l [catch {interp invokehidden a list {$z a b c}} msg] 1147 lappend l $msg 1148 interp delete a 1149 set l 1150} {0 {{$z a b c}}} 1151test interp-20.17 {interp invokehidden vs variable eval} { 1152 catch {interp delete a} 1153 interp create a 1154 interp hide a list 1155 a eval set z 89 1156 set z 45 1157 set l "" 1158 lappend l [catch {interp invokehidden a list {$z a b c}} msg] 1159 lappend l $msg 1160 interp delete a 1161 set l 1162} {0 {{$z a b c}}} 1163test interp-20.18 {interp invokehidden vs variable eval} { 1164 catch {interp delete a} 1165 interp create a 1166 interp hide a list 1167 a eval set z 89 1168 set z 45 1169 set l "" 1170 lappend l [catch {interp invokehidden a list $z {$z a b c}} msg] 1171 lappend l $msg 1172 interp delete a 1173 set l 1174} {0 {45 {$z a b c}}} 1175test interp-20.19 {interp invokehidden vs nested commands} { 1176 catch {interp delete a} 1177 interp create a 1178 a hide list 1179 set l [a invokehidden list {[list x y z] f g h} z] 1180 interp delete a 1181 set l 1182} {{[list x y z] f g h} z} 1183test interp-20.20 {interp invokehidden vs nested commands} { 1184 catch {interp delete a} 1185 interp create a 1186 a hide list 1187 set l [interp invokehidden a list {[list x y z] f g h} z] 1188 interp delete a 1189 set l 1190} {{[list x y z] f g h} z} 1191test interp-20.21 {interp hide vs safety} { 1192 catch {interp delete a} 1193 interp create a -safe 1194 set l "" 1195 lappend l [catch {a hide list} msg] 1196 lappend l $msg 1197 interp delete a 1198 set l 1199} {0 {}} 1200test interp-20.22 {interp hide vs safety} { 1201 catch {interp delete a} 1202 interp create a -safe 1203 set l "" 1204 lappend l [catch {interp hide a list} msg] 1205 lappend l $msg 1206 interp delete a 1207 set l 1208} {0 {}} 1209test interp-20.23 {interp hide vs safety} { 1210 catch {interp delete a} 1211 interp create a -safe 1212 set l "" 1213 lappend l [catch {a eval {interp hide {} list}} msg] 1214 lappend l $msg 1215 interp delete a 1216 set l 1217} {1 {permission denied: safe interpreter cannot hide commands}} 1218test interp-20.24 {interp hide vs safety} { 1219 catch {interp delete a} 1220 interp create a -safe 1221 interp create {a b} 1222 set l "" 1223 lappend l [catch {a eval {interp hide b list}} msg] 1224 lappend l $msg 1225 interp delete a 1226 set l 1227} {1 {permission denied: safe interpreter cannot hide commands}} 1228test interp-20.25 {interp hide vs safety} { 1229 catch {interp delete a} 1230 interp create a -safe 1231 interp create {a b} 1232 set l "" 1233 lappend l [catch {interp hide {a b} list} msg] 1234 lappend l $msg 1235 interp delete a 1236 set l 1237} {0 {}} 1238test interp-20.26 {interp expoose vs safety} { 1239 catch {interp delete a} 1240 interp create a -safe 1241 set l "" 1242 lappend l [catch {a hide list} msg] 1243 lappend l $msg 1244 lappend l [catch {a expose list} msg] 1245 lappend l $msg 1246 interp delete a 1247 set l 1248} {0 {} 0 {}} 1249test interp-20.27 {interp expose vs safety} { 1250 catch {interp delete a} 1251 interp create a -safe 1252 set l "" 1253 lappend l [catch {interp hide a list} msg] 1254 lappend l $msg 1255 lappend l [catch {interp expose a list} msg] 1256 lappend l $msg 1257 interp delete a 1258 set l 1259} {0 {} 0 {}} 1260test interp-20.28 {interp expose vs safety} { 1261 catch {interp delete a} 1262 interp create a -safe 1263 set l "" 1264 lappend l [catch {a hide list} msg] 1265 lappend l $msg 1266 lappend l [catch {a eval {interp expose {} list}} msg] 1267 lappend l $msg 1268 interp delete a 1269 set l 1270} {0 {} 1 {permission denied: safe interpreter cannot expose commands}} 1271test interp-20.29 {interp expose vs safety} { 1272 catch {interp delete a} 1273 interp create a -safe 1274 set l "" 1275 lappend l [catch {interp hide a list} msg] 1276 lappend l $msg 1277 lappend l [catch {a eval {interp expose {} list}} msg] 1278 lappend l $msg 1279 interp delete a 1280 set l 1281} {0 {} 1 {permission denied: safe interpreter cannot expose commands}} 1282test interp-20.30 {interp expose vs safety} { 1283 catch {interp delete a} 1284 interp create a -safe 1285 interp create {a b} 1286 set l "" 1287 lappend l [catch {interp hide {a b} list} msg] 1288 lappend l $msg 1289 lappend l [catch {a eval {interp expose b list}} msg] 1290 lappend l $msg 1291 interp delete a 1292 set l 1293} {0 {} 1 {permission denied: safe interpreter cannot expose commands}} 1294test interp-20.31 {interp expose vs safety} { 1295 catch {interp delete a} 1296 interp create a -safe 1297 interp create {a b} 1298 set l "" 1299 lappend l [catch {interp hide {a b} list} msg] 1300 lappend l $msg 1301 lappend l [catch {interp expose {a b} list} msg] 1302 lappend l $msg 1303 interp delete a 1304 set l 1305} {0 {} 0 {}} 1306test interp-20.32 {interp invokehidden vs safety} { 1307 catch {interp delete a} 1308 interp create a -safe 1309 interp hide a list 1310 set l "" 1311 lappend l [catch {a eval {interp invokehidden {} list a b c}} msg] 1312 lappend l $msg 1313 interp delete a 1314 set l 1315} {1 {not allowed to invoke hidden commands from safe interpreter}} 1316test interp-20.33 {interp invokehidden vs safety} { 1317 catch {interp delete a} 1318 interp create a -safe 1319 interp hide a list 1320 set l "" 1321 lappend l [catch {a eval {interp invokehidden {} list a b c}} msg] 1322 lappend l $msg 1323 lappend l [catch {a invokehidden list a b c} msg] 1324 lappend l $msg 1325 interp delete a 1326 set l 1327} {1 {not allowed to invoke hidden commands from safe interpreter}\ 13280 {a b c}} 1329test interp-20.34 {interp invokehidden vs safety} { 1330 catch {interp delete a} 1331 interp create a -safe 1332 interp create {a b} 1333 interp hide {a b} list 1334 set l "" 1335 lappend l [catch {a eval {interp invokehidden b list a b c}} msg] 1336 lappend l $msg 1337 lappend l [catch {interp invokehidden {a b} list a b c} msg] 1338 lappend l $msg 1339 interp delete a 1340 set l 1341} {1 {not allowed to invoke hidden commands from safe interpreter}\ 13420 {a b c}} 1343test interp-20.35 {invokehidden at local level} { 1344 catch {interp delete a} 1345 interp create a 1346 a eval { 1347 proc p1 {} { 1348 set z 90 1349 a1 1350 set z 1351 } 1352 proc h1 {} { 1353 upvar z z 1354 set z 91 1355 } 1356 } 1357 a hide h1 1358 a alias a1 a1 1359 proc a1 {} { 1360 interp invokehidden a h1 1361 } 1362 set r [interp eval a p1] 1363 interp delete a 1364 set r 1365} 91 1366test interp-20.36 {invokehidden at local level} { 1367 catch {interp delete a} 1368 interp create a 1369 a eval { 1370 set z 90 1371 proc p1 {} { 1372 global z 1373 a1 1374 set z 1375 } 1376 proc h1 {} { 1377 upvar z z 1378 set z 91 1379 } 1380 } 1381 a hide h1 1382 a alias a1 a1 1383 proc a1 {} { 1384 interp invokehidden a h1 1385 } 1386 set r [interp eval a p1] 1387 interp delete a 1388 set r 1389} 91 1390test interp-20.37 {invokehidden at local level} { 1391 catch {interp delete a} 1392 interp create a 1393 a eval { 1394 proc p1 {} { 1395 a1 1396 set z 1397 } 1398 proc h1 {} { 1399 upvar z z 1400 set z 91 1401 } 1402 } 1403 a hide h1 1404 a alias a1 a1 1405 proc a1 {} { 1406 interp invokehidden a h1 1407 } 1408 set r [interp eval a p1] 1409 interp delete a 1410 set r 1411} 91 1412test interp-20.38 {invokehidden at global level} { 1413 catch {interp delete a} 1414 interp create a 1415 a eval { 1416 proc p1 {} { 1417 a1 1418 set z 1419 } 1420 proc h1 {} { 1421 upvar z z 1422 set z 91 1423 } 1424 } 1425 a hide h1 1426 a alias a1 a1 1427 proc a1 {} { 1428 interp invokehidden a -global h1 1429 } 1430 set r [catch {interp eval a p1} msg] 1431 interp delete a 1432 list $r $msg 1433} {1 {can't read "z": no such variable}} 1434test interp-20.39 {invokehidden at global level} { 1435 catch {interp delete a} 1436 interp create a 1437 a eval { 1438 proc p1 {} { 1439 global z 1440 a1 1441 set z 1442 } 1443 proc h1 {} { 1444 upvar z z 1445 set z 91 1446 } 1447 } 1448 a hide h1 1449 a alias a1 a1 1450 proc a1 {} { 1451 interp invokehidden a -global h1 1452 } 1453 set r [catch {interp eval a p1} msg] 1454 interp delete a 1455 list $r $msg 1456} {0 91} 1457test interp-20.40 {safe, invokehidden at local level} { 1458 catch {interp delete a} 1459 interp create a -safe 1460 a eval { 1461 proc p1 {} { 1462 set z 90 1463 a1 1464 set z 1465 } 1466 proc h1 {} { 1467 upvar z z 1468 set z 91 1469 } 1470 } 1471 a hide h1 1472 a alias a1 a1 1473 proc a1 {} { 1474 interp invokehidden a h1 1475 } 1476 set r [interp eval a p1] 1477 interp delete a 1478 set r 1479} 91 1480test interp-20.41 {safe, invokehidden at local level} { 1481 catch {interp delete a} 1482 interp create a -safe 1483 a eval { 1484 set z 90 1485 proc p1 {} { 1486 global z 1487 a1 1488 set z 1489 } 1490 proc h1 {} { 1491 upvar z z 1492 set z 91 1493 } 1494 } 1495 a hide h1 1496 a alias a1 a1 1497 proc a1 {} { 1498 interp invokehidden a h1 1499 } 1500 set r [interp eval a p1] 1501 interp delete a 1502 set r 1503} 91 1504test interp-20.42 {safe, invokehidden at local level} { 1505 catch {interp delete a} 1506 interp create a -safe 1507 a eval { 1508 proc p1 {} { 1509 a1 1510 set z 1511 } 1512 proc h1 {} { 1513 upvar z z 1514 set z 91 1515 } 1516 } 1517 a hide h1 1518 a alias a1 a1 1519 proc a1 {} { 1520 interp invokehidden a h1 1521 } 1522 set r [interp eval a p1] 1523 interp delete a 1524 set r 1525} 91 1526test interp-20.43 {invokehidden at global level} { 1527 catch {interp delete a} 1528 interp create a 1529 a eval { 1530 proc p1 {} { 1531 a1 1532 set z 1533 } 1534 proc h1 {} { 1535 upvar z z 1536 set z 91 1537 } 1538 } 1539 a hide h1 1540 a alias a1 a1 1541 proc a1 {} { 1542 interp invokehidden a -global h1 1543 } 1544 set r [catch {interp eval a p1} msg] 1545 interp delete a 1546 list $r $msg 1547} {1 {can't read "z": no such variable}} 1548test interp-20.44 {invokehidden at global level} { 1549 catch {interp delete a} 1550 interp create a 1551 a eval { 1552 proc p1 {} { 1553 global z 1554 a1 1555 set z 1556 } 1557 proc h1 {} { 1558 upvar z z 1559 set z 91 1560 } 1561 } 1562 a hide h1 1563 a alias a1 a1 1564 proc a1 {} { 1565 interp invokehidden a -global h1 1566 } 1567 set r [catch {interp eval a p1} msg] 1568 interp delete a 1569 list $r $msg 1570} {0 91} 1571test interp-20.45 {interp hide vs namespaces} { 1572 catch {interp delete a} 1573 interp create a 1574 a eval { 1575 namespace eval foo {} 1576 proc foo::x {} {} 1577 } 1578 set l [list [catch {interp hide a foo::x} msg] $msg] 1579 interp delete a 1580 set l 1581} {1 {cannot use namespace qualifiers in hidden command token (rename)}} 1582test interp-20.46 {interp hide vs namespaces} { 1583 catch {interp delete a} 1584 interp create a 1585 a eval { 1586 namespace eval foo {} 1587 proc foo::x {} {} 1588 } 1589 set l [list [catch {interp hide a foo::x x} msg] $msg] 1590 interp delete a 1591 set l 1592} {1 {can only hide global namespace commands (use rename then hide)}} 1593test interp-20.47 {interp hide vs namespaces} { 1594 catch {interp delete a} 1595 interp create a 1596 a eval { 1597 proc x {} {} 1598 } 1599 set l [list [catch {interp hide a x foo::x} msg] $msg] 1600 interp delete a 1601 set l 1602} {1 {cannot use namespace qualifiers in hidden command token (rename)}} 1603test interp-20.48 {interp hide vs namespaces} { 1604 catch {interp delete a} 1605 interp create a 1606 a eval { 1607 namespace eval foo {} 1608 proc foo::x {} {} 1609 } 1610 set l [list [catch {interp hide a foo::x bar::x} msg] $msg] 1611 interp delete a 1612 set l 1613} {1 {cannot use namespace qualifiers in hidden command token (rename)}} 1614test interp-20.49 {interp invokehidden -namespace} -setup { 1615 set script [makeFile { 1616 set x [namespace current] 1617 } script] 1618 interp create -safe child 1619} -body { 1620 child invokehidden -namespace ::foo source $script 1621 child eval {set ::foo::x} 1622} -cleanup { 1623 interp delete child 1624 removeFile script 1625} -result ::foo 1626test interp-20.50 {Bug 2486550} -setup { 1627 interp create child 1628} -body { 1629 child hide coroutine 1630 child invokehidden coroutine 1631} -cleanup { 1632 interp delete child 1633} -returnCodes error -match glob -result * 1634test interp-20.50.1 {Bug 2486550} -setup { 1635 interp create child 1636} -body { 1637 child hide coroutine 1638 catch {child invokehidden coroutine} m o 1639 dict get $o -errorinfo 1640} -cleanup { 1641 unset -nocomplain m 0 1642 interp delete child 1643} -returnCodes ok -result {wrong # args: should be "coroutine name cmd ?arg ...?" 1644 while executing 1645"coroutine" 1646 invoked from within 1647"child invokehidden coroutine"} 1648 1649test interp-21.1 {interp hidden} { 1650 interp hidden {} 1651} "" 1652test interp-21.2 {interp hidden} { 1653 interp hidden 1654} "" 1655test interp-21.3 {interp hidden vs interp hide, interp expose} -setup { 1656 set l "" 1657} -body { 1658 lappend l [interp hidden] 1659 interp hide {} pwd 1660 lappend l [interp hidden] 1661 interp expose {} pwd 1662 lappend l [interp hidden] 1663} -result {{} pwd {}} 1664test interp-21.4 {interp hidden} -setup { 1665 catch {interp delete a} 1666} -body { 1667 interp create a 1668 interp hidden a 1669} -cleanup { 1670 interp delete a 1671} -result "" 1672test interp-21.5 {interp hidden} -setup { 1673 catch {interp delete a} 1674} -body { 1675 interp create -safe a 1676 lsort [interp hidden a] 1677} -cleanup { 1678 interp delete a 1679} -result $hidden_cmds 1680test interp-21.6 {interp hidden vs interp hide, interp expose} -setup { 1681 catch {interp delete a} 1682 set l "" 1683} -body { 1684 interp create a 1685 lappend l [interp hidden a] 1686 interp hide a pwd 1687 lappend l [interp hidden a] 1688 interp expose a pwd 1689 lappend l [interp hidden a] 1690} -cleanup { 1691 interp delete a 1692} -result {{} pwd {}} 1693test interp-21.7 {interp hidden} -setup { 1694 catch {interp delete a} 1695} -body { 1696 interp create a 1697 a hidden 1698} -cleanup { 1699 interp delete a 1700} -result "" 1701test interp-21.8 {interp hidden} -setup { 1702 catch {interp delete a} 1703} -body { 1704 interp create a -safe 1705 lsort [a hidden] 1706} -cleanup { 1707 interp delete a 1708} -result $hidden_cmds 1709test interp-21.9 {interp hidden vs interp hide, interp expose} -setup { 1710 catch {interp delete a} 1711 set l "" 1712} -body { 1713 interp create a 1714 lappend l [a hidden] 1715 a hide pwd 1716 lappend l [a hidden] 1717 a expose pwd 1718 lappend l [a hidden] 1719} -cleanup { 1720 interp delete a 1721} -result {{} pwd {}} 1722 1723test interp-22.1 {testing interp marktrusted} { 1724 catch {interp delete a} 1725 interp create a 1726 set l "" 1727 lappend l [a issafe] 1728 lappend l [a marktrusted] 1729 lappend l [a issafe] 1730 interp delete a 1731 set l 1732} {0 {} 0} 1733test interp-22.2 {testing interp marktrusted} { 1734 catch {interp delete a} 1735 interp create a 1736 set l "" 1737 lappend l [interp issafe a] 1738 lappend l [interp marktrusted a] 1739 lappend l [interp issafe a] 1740 interp delete a 1741 set l 1742} {0 {} 0} 1743test interp-22.3 {testing interp marktrusted} { 1744 catch {interp delete a} 1745 interp create a -safe 1746 set l "" 1747 lappend l [a issafe] 1748 lappend l [a marktrusted] 1749 lappend l [a issafe] 1750 interp delete a 1751 set l 1752} {1 {} 0} 1753test interp-22.4 {testing interp marktrusted} { 1754 catch {interp delete a} 1755 interp create a -safe 1756 set l "" 1757 lappend l [interp issafe a] 1758 lappend l [interp marktrusted a] 1759 lappend l [interp issafe a] 1760 interp delete a 1761 set l 1762} {1 {} 0} 1763test interp-22.5 {testing interp marktrusted} { 1764 catch {interp delete a} 1765 interp create a -safe 1766 interp create {a b} 1767 catch {a eval {interp marktrusted b}} msg 1768 interp delete a 1769 set msg 1770} {permission denied: safe interpreter cannot mark trusted} 1771test interp-22.6 {testing interp marktrusted} { 1772 catch {interp delete a} 1773 interp create a -safe 1774 interp create {a b} 1775 catch {a eval {b marktrusted}} msg 1776 interp delete a 1777 set msg 1778} {permission denied: safe interpreter cannot mark trusted} 1779test interp-22.7 {testing interp marktrusted} { 1780 catch {interp delete a} 1781 interp create a -safe 1782 set l "" 1783 lappend l [interp issafe a] 1784 interp marktrusted a 1785 interp create {a b} 1786 lappend l [interp issafe a] 1787 lappend l [interp issafe {a b}] 1788 interp delete a 1789 set l 1790} {1 0 0} 1791test interp-22.8 {testing interp marktrusted} { 1792 catch {interp delete a} 1793 interp create a -safe 1794 set l "" 1795 lappend l [interp issafe a] 1796 interp create {a b} 1797 lappend l [interp issafe {a b}] 1798 interp marktrusted a 1799 interp create {a c} 1800 lappend l [interp issafe a] 1801 lappend l [interp issafe {a c}] 1802 interp delete a 1803 set l 1804} {1 1 0 0} 1805test interp-22.9 {testing interp marktrusted} { 1806 catch {interp delete a} 1807 interp create a -safe 1808 set l "" 1809 lappend l [interp issafe a] 1810 interp create {a b} 1811 lappend l [interp issafe {a b}] 1812 interp marktrusted {a b} 1813 lappend l [interp issafe a] 1814 lappend l [interp issafe {a b}] 1815 interp create {a b c} 1816 lappend l [interp issafe {a b c}] 1817 interp delete a 1818 set l 1819} {1 1 1 0 0} 1820 1821test interp-23.1 {testing hiding vs aliases: unsafe interp} -setup { 1822 catch {interp delete a} 1823 set l "" 1824} -body { 1825 interp create a 1826 lappend l [interp hidden a] 1827 a alias bar bar 1828 lappend l [interp aliases a] [interp hidden a] 1829 a hide bar 1830 lappend l [interp aliases a] [interp hidden a] 1831 a alias bar {} 1832 lappend l [interp aliases a] [interp hidden a] 1833} -cleanup { 1834 interp delete a 1835} -result {{} bar {} bar bar {} {}} 1836test interp-23.2 {testing hiding vs aliases: safe interp} -setup { 1837 catch {interp delete a} 1838 set l "" 1839} -constraints {unixOrWin} -body { 1840 interp create a -safe 1841 lappend l [lsort [interp hidden a]] 1842 a alias bar bar 1843 lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] 1844 a hide bar 1845 lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] 1846 a alias bar {} 1847 lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] 1848} -cleanup { 1849 interp delete a 1850} -result [list $hidden_cmds {bar clock} $hidden_cmds {bar clock} [lsort [concat $hidden_cmds bar]] {clock} $hidden_cmds] 1851 1852test interp-24.1 {result resetting on error} -setup { 1853 catch {interp delete a} 1854} -body { 1855 interp create a 1856 interp alias a foo {} apply {args {error $args}} 1857 interp eval a { 1858 lappend l [catch {foo 1 2 3} msg] $msg 1859 lappend l [catch {foo 3 4 5} msg] $msg 1860 } 1861} -cleanup { 1862 interp delete a 1863} -result {1 {1 2 3} 1 {3 4 5}} 1864test interp-24.2 {result resetting on error} -setup { 1865 catch {interp delete a} 1866} -body { 1867 interp create a -safe 1868 interp alias a foo {} apply {args {error $args}} 1869 interp eval a { 1870 lappend l [catch {foo 1 2 3} msg] $msg 1871 lappend l [catch {foo 3 4 5} msg] $msg 1872 } 1873} -cleanup { 1874 interp delete a 1875} -result {1 {1 2 3} 1 {3 4 5}} 1876test interp-24.3 {result resetting on error} -setup { 1877 catch {interp delete a} 1878} -body { 1879 interp create a 1880 interp create {a b} 1881 interp eval a { 1882 proc foo args {error $args} 1883 } 1884 interp alias {a b} foo a foo 1885 interp eval {a b} { 1886 lappend l [catch {foo 1 2 3} msg] $msg 1887 lappend l [catch {foo 3 4 5} msg] $msg 1888 } 1889} -cleanup { 1890 interp delete a 1891} -result {1 {1 2 3} 1 {3 4 5}} 1892test interp-24.4 {result resetting on error} -setup { 1893 catch {interp delete a} 1894} -body { 1895 interp create a -safe 1896 interp create {a b} 1897 interp eval a { 1898 proc foo args {error $args} 1899 } 1900 interp alias {a b} foo a foo 1901 interp eval {a b} { 1902 lappend l [catch {foo 1 2 3} msg] 1903 lappend l $msg 1904 lappend l [catch {foo 3 4 5} msg] 1905 lappend l $msg 1906 } 1907} -cleanup { 1908 interp delete a 1909} -result {1 {1 2 3} 1 {3 4 5}} 1910test interp-24.5 {result resetting on error} -setup { 1911 catch {interp delete a} 1912 catch {interp delete b} 1913} -body { 1914 interp create a 1915 interp create b 1916 interp eval a { 1917 proc foo args {error $args} 1918 } 1919 interp alias b foo a foo 1920 interp eval b { 1921 lappend l [catch {foo 1 2 3} msg] $msg 1922 lappend l [catch {foo 3 4 5} msg] $msg 1923 } 1924} -cleanup { 1925 interp delete a 1926 interp delete b 1927} -result {1 {1 2 3} 1 {3 4 5}} 1928test interp-24.6 {result resetting on error} -setup { 1929 catch {interp delete a} 1930 catch {interp delete b} 1931} -body { 1932 interp create a -safe 1933 interp create b -safe 1934 interp eval a { 1935 proc foo args {error $args} 1936 } 1937 interp alias b foo a foo 1938 interp eval b { 1939 lappend l [catch {foo 1 2 3} msg] $msg 1940 lappend l [catch {foo 3 4 5} msg] $msg 1941 } 1942} -cleanup { 1943 interp delete a 1944 interp delete b 1945} -result {1 {1 2 3} 1 {3 4 5}} 1946test interp-24.7 {result resetting on error} -setup { 1947 catch {interp delete a} 1948 set l {} 1949} -body { 1950 interp create a 1951 interp eval a { 1952 proc foo args {error $args} 1953 } 1954 lappend l [catch {interp eval a foo 1 2 3} msg] $msg 1955 lappend l [catch {interp eval a foo 3 4 5} msg] $msg 1956} -cleanup { 1957 interp delete a 1958} -result {1 {1 2 3} 1 {3 4 5}} 1959test interp-24.8 {result resetting on error} -setup { 1960 catch {interp delete a} 1961 set l {} 1962} -body { 1963 interp create a -safe 1964 interp eval a { 1965 proc foo args {error $args} 1966 } 1967 lappend l [catch {interp eval a foo 1 2 3} msg] $msg 1968 lappend l [catch {interp eval a foo 3 4 5} msg] $msg 1969} -cleanup { 1970 interp delete a 1971} -result {1 {1 2 3} 1 {3 4 5}} 1972test interp-24.9 {result resetting on error} -setup { 1973 catch {interp delete a} 1974 set l {} 1975} -body { 1976 interp create a 1977 interp create {a b} 1978 interp eval {a b} { 1979 proc foo args {error $args} 1980 } 1981 interp eval a { 1982 proc foo args { 1983 eval interp eval b foo $args 1984 } 1985 } 1986 lappend l [catch {interp eval a foo 1 2 3} msg] $msg 1987 lappend l [catch {interp eval a foo 3 4 5} msg] $msg 1988} -cleanup { 1989 interp delete a 1990} -result {1 {1 2 3} 1 {3 4 5}} 1991test interp-24.10 {result resetting on error} -setup { 1992 catch {interp delete a} 1993 set l {} 1994} -body { 1995 interp create a -safe 1996 interp create {a b} 1997 interp eval {a b} { 1998 proc foo args {error $args} 1999 } 2000 interp eval a { 2001 proc foo args { 2002 eval interp eval b foo $args 2003 } 2004 } 2005 lappend l [catch {interp eval a foo 1 2 3} msg] $msg 2006 lappend l [catch {interp eval a foo 3 4 5} msg] $msg 2007} -cleanup { 2008 interp delete a 2009} -result {1 {1 2 3} 1 {3 4 5}} 2010test interp-24.11 {result resetting on error} -setup { 2011 catch {interp delete a} 2012} -body { 2013 interp create a 2014 interp create {a b} 2015 interp eval {a b} { 2016 proc foo args {error $args} 2017 } 2018 interp eval a { 2019 proc foo args { 2020 lappend l [catch {eval interp eval b foo $args} msg] $msg 2021 lappend l [catch {eval interp eval b foo $args} msg] $msg 2022 } 2023 } 2024 interp eval a foo 1 2 3 2025} -cleanup { 2026 interp delete a 2027} -result {1 {1 2 3} 1 {1 2 3}} 2028test interp-24.12 {result resetting on error} -setup { 2029 catch {interp delete a} 2030} -body { 2031 interp create a -safe 2032 interp create {a b} 2033 interp eval {a b} { 2034 proc foo args {error $args} 2035 } 2036 interp eval a { 2037 proc foo args { 2038 lappend l [catch {eval interp eval b foo $args} msg] $msg 2039 lappend l [catch {eval interp eval b foo $args} msg] $msg 2040 } 2041 } 2042 interp eval a foo 1 2 3 2043} -cleanup { 2044 interp delete a 2045} -result {1 {1 2 3} 1 {1 2 3}} 2046 2047test interp-25.1 {testing aliasing of string commands} -setup { 2048 catch {interp delete a} 2049} -body { 2050 interp create a 2051 a alias exec foo ;# Relies on exec being a string command! 2052 interp delete a 2053} -result "" 2054 2055# 2056# Interps result transmission 2057# 2058 2059test interp-26.1 {result code transmission : interp eval direct} { 2060 # Test that all the possibles error codes from Tcl get passed up 2061 # from the child interp's context to the parent, even though the 2062 # child nominally thinks the command is running at the root level. 2063 catch {interp delete a} 2064 interp create a 2065 set res {} 2066 # use a for so if a return -code break 'escapes' we would notice 2067 for {set code -1} {$code<=5} {incr code} { 2068 lappend res [catch {interp eval a return -code $code} msg] 2069 } 2070 interp delete a 2071 set res 2072} {-1 0 1 2 3 4 5} 2073test interp-26.2 {result code transmission : interp eval indirect} { 2074 # retcode == 2 == return is special 2075 catch {interp delete a} 2076 interp create a 2077 interp eval a {proc retcode {code} {return -code $code ret$code}} 2078 set res {} 2079 # use a for so if a return -code break 'escapes' we would notice 2080 for {set code -1} {$code<=5} {incr code} { 2081 lappend res [catch {interp eval a retcode $code} msg] $msg 2082 } 2083 interp delete a 2084 set res 2085} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5} 2086test interp-26.3 {result code transmission : aliases} { 2087 # Test that all the possibles error codes from Tcl get passed up from the 2088 # child interp's context to the parent, even though the child nominally 2089 # thinks the command is running at the root level. 2090 catch {interp delete a} 2091 interp create a 2092 set res {} 2093 proc MyTestAlias {code} { 2094 return -code $code ret$code 2095 } 2096 interp alias a Test {} MyTestAlias 2097 for {set code -1} {$code<=5} {incr code} { 2098 lappend res [interp eval a [list catch [list Test $code] msg]] 2099 } 2100 interp delete a 2101 set res 2102} {-1 0 1 2 3 4 5} 2103test interp-26.4 {result code transmission: invoke hidden direct--bug 1637} \ 2104 {knownBug} { 2105 # The known bug is that code 2 is returned, not the -code argument 2106 catch {interp delete a} 2107 interp create a 2108 set res {} 2109 interp hide a return 2110 for {set code -1} {$code<=5} {incr code} { 2111 lappend res [catch {interp invokehidden a return -code $code ret$code}] 2112 } 2113 interp delete a 2114 set res 2115} {-1 0 1 2 3 4 5} 2116test interp-26.5 {result code transmission: invoke hidden indirect--bug 1637} -setup { 2117 catch {interp delete a} 2118 interp create a 2119} -body { 2120 # The known bug is that the break and continue should raise errors that 2121 # they are used outside a loop. 2122 set res {} 2123 interp eval a {proc retcode {code} {return -code $code ret$code}} 2124 interp hide a retcode 2125 for {set code -1} {$code<=5} {incr code} { 2126 lappend res [catch {interp invokehidden a retcode $code} msg] $msg 2127 } 2128 return $res 2129} -cleanup { 2130 interp delete a 2131} -result {-1 ret-1 0 ret0 1 ret1 2 ret2 3 ret3 4 ret4 5 ret5} 2132test interp-26.6 {result code transmission: all combined--bug 1637} -setup { 2133 set interp [interp create] 2134} -constraints knownBug -body { 2135 # Test that all the possibles error codes from Tcl get passed in both 2136 # directions. This doesn't work. 2137 proc MyTestAlias {interp args} { 2138 global aliasTrace 2139 lappend aliasTrace $args 2140 interp invokehidden $interp {*}$args 2141 } 2142 foreach c {return} { 2143 interp hide $interp $c 2144 interp alias $interp $c {} MyTestAlias $interp $c 2145 } 2146 interp eval $interp {proc ret {code} {return -code $code ret$code}} 2147 set res {} 2148 set aliasTrace {} 2149 for {set code -1} {$code<=5} {incr code} { 2150 lappend res [catch {interp eval $interp ret $code} msg] $msg 2151 } 2152 return $res 2153} -cleanup { 2154 interp delete $interp 2155} -result {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5} 2156# Some tests might need to be added to check for difference between toplevel 2157# and non-toplevel evals. 2158# End of return code transmission section 2159test interp-26.7 {errorInfo transmission: regular interps} -setup { 2160 set interp [interp create] 2161} -body { 2162 proc MyError {secret} { 2163 return -code error "msg" 2164 } 2165 proc MyTestAlias {interp args} { 2166 MyError "some secret" 2167 } 2168 interp alias $interp test {} MyTestAlias $interp 2169 interp eval $interp {catch test;set ::errorInfo} 2170} -cleanup { 2171 interp delete $interp 2172} -result {msg 2173 while executing 2174"MyError "some secret"" 2175 (procedure "MyTestAlias" line 2) 2176 invoked from within 2177"test"} 2178test interp-26.8 {errorInfo transmission: safe interps--bug 1637} -setup { 2179 set interp [interp create -safe] 2180} -constraints knownBug -body { 2181 # this test fails because the errorInfo is fully transmitted whether the 2182 # interp is safe or not. The errorInfo should never report data from the 2183 # parent interpreter because it could contain sensitive information. 2184 proc MyError {secret} { 2185 return -code error "msg" 2186 } 2187 proc MyTestAlias {interp args} { 2188 MyError "some secret" 2189 } 2190 interp alias $interp test {} MyTestAlias $interp 2191 interp eval $interp {catch test;set ::errorInfo} 2192} -cleanup { 2193 interp delete $interp 2194} -result {msg 2195 while executing 2196"test"} 2197 2198# Interps & Namespaces 2199test interp-27.1 {interp aliases & namespaces} -setup { 2200 set i [interp create] 2201} -body { 2202 set aliasTrace {} 2203 proc tstAlias {args} { 2204 global aliasTrace 2205 lappend aliasTrace [list [namespace current] $args] 2206 } 2207 $i alias foo::bar tstAlias foo::bar 2208 $i eval foo::bar test 2209 return $aliasTrace 2210} -cleanup { 2211 interp delete $i 2212} -result {{:: {foo::bar test}}} 2213test interp-27.2 {interp aliases & namespaces} -setup { 2214 set i [interp create] 2215} -body { 2216 set aliasTrace {} 2217 proc tstAlias {args} { 2218 global aliasTrace 2219 lappend aliasTrace [list [namespace current] $args] 2220 } 2221 $i alias foo::bar tstAlias foo::bar 2222 $i eval namespace eval foo {bar test} 2223 return $aliasTrace 2224} -cleanup { 2225 interp delete $i 2226} -result {{:: {foo::bar test}}} 2227test interp-27.3 {interp aliases & namespaces} -setup { 2228 set i [interp create] 2229} -body { 2230 set aliasTrace {} 2231 proc tstAlias {args} { 2232 global aliasTrace 2233 lappend aliasTrace [list [namespace current] $args] 2234 } 2235 interp eval $i {namespace eval foo {proc bar {} {error "bar called"}}} 2236 interp alias $i foo::bar {} tstAlias foo::bar 2237 interp eval $i {namespace eval foo {bar test}} 2238 return $aliasTrace 2239} -cleanup { 2240 interp delete $i 2241} -result {{:: {foo::bar test}}} 2242test interp-27.4 {interp aliases & namespaces} -setup { 2243 set i [interp create] 2244} -body { 2245 namespace eval foo2 { 2246 variable aliasTrace {} 2247 proc bar {args} { 2248 variable aliasTrace 2249 lappend aliasTrace [list [namespace current] $args] 2250 } 2251 } 2252 $i alias foo::bar foo2::bar foo::bar 2253 $i eval namespace eval foo {bar test} 2254 return $foo2::aliasTrace 2255} -cleanup { 2256 namespace delete foo2 2257 interp delete $i 2258} -result {{::foo2 {foo::bar test}}} 2259test interp-27.5 {interp hidden & namespaces} -setup { 2260 set i [interp create] 2261} -constraints knownBug -body { 2262 interp eval $i { 2263 namespace eval foo { 2264 proc bar {args} { 2265 return "bar called ([namespace current]) ($args)" 2266 } 2267 } 2268 } 2269 set res [list [interp eval $i {namespace eval foo {bar test1}}]] 2270 interp hide $i foo::bar 2271 lappend res [list [catch {interp eval $i {namespace eval foo {bar test2}}} msg] $msg] 2272} -cleanup { 2273 interp delete $i 2274} -result {{bar called (::foo) (test1)} {1 {invalid command name "bar"}}} 2275test interp-27.6 {interp hidden & aliases & namespaces} -setup { 2276 set i [interp create] 2277} -constraints knownBug -body { 2278 set v root-parent 2279 namespace eval foo { 2280 variable v foo-parent 2281 proc bar {interp args} { 2282 variable v 2283 list "parent bar called ($v) ([namespace current]) ($args)"\ 2284 [interp invokehidden $interp foo::bar $args] 2285 } 2286 } 2287 interp eval $i { 2288 namespace eval foo { 2289 namespace export * 2290 variable v foo-child 2291 proc bar {args} { 2292 variable v 2293 return "child bar called ($v) ([namespace current]) ($args)" 2294 } 2295 } 2296 } 2297 set res [list [interp eval $i {namespace eval foo {bar test1}}]] 2298 $i hide foo::bar 2299 $i alias foo::bar foo::bar $i 2300 set res [concat $res [interp eval $i { 2301 set v root-child 2302 namespace eval test { 2303 variable v foo-test 2304 namespace import ::foo::* 2305 bar test2 2306 } 2307 }]] 2308} -cleanup { 2309 namespace delete foo 2310 interp delete $i 2311} -result {{child bar called (foo-child) (::foo) (test1)} {parent bar called (foo-parent) (::foo) (test2)} {child bar called (foo-child) (::foo) (test2)}} 2312test interp-27.7 {interp hidden & aliases & imports & namespaces} -setup { 2313 set i [interp create] 2314} -constraints knownBug -body { 2315 set v root-parent 2316 namespace eval mfoo { 2317 variable v foo-parent 2318 proc bar {interp args} { 2319 variable v 2320 list "parent bar called ($v) ([namespace current]) ($args)"\ 2321 [interp invokehidden $interp test::bar $args] 2322 } 2323 } 2324 interp eval $i { 2325 namespace eval foo { 2326 namespace export * 2327 variable v foo-child 2328 proc bar {args} { 2329 variable v 2330 return "child bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)" 2331 } 2332 } 2333 set v root-child 2334 namespace eval test { 2335 variable v foo-test 2336 namespace import ::foo::* 2337 } 2338 } 2339 set res [list [interp eval $i {namespace eval test {bar test1}}]] 2340 $i hide test::bar 2341 $i alias test::bar mfoo::bar $i 2342 set res [concat $res [interp eval $i {test::bar test2}]] 2343} -cleanup { 2344 namespace delete mfoo 2345 interp delete $i 2346} -result {{child bar called (foo-child) (bar test1) (::tcltest) (::foo) (test1)} {parent bar called (foo-parent) (::mfoo) (test2)} {child bar called (foo-child) (test::bar test2) (::) (::foo) (test2)}} 2347test interp-27.8 {hiding, namespaces and integrity} knownBug { 2348 namespace eval foo { 2349 variable v 3 2350 proc bar {} {variable v; set v} 2351 # next command would currently generate an unknown command "bar" error. 2352 interp hide {} bar 2353 } 2354 namespace delete foo 2355 list [catch {interp invokehidden {} foo::bar} msg] $msg 2356} {1 {invalid hidden command name "foo"}} 2357 2358test interp-28.1 {getting fooled by child's namespace ?} -setup { 2359 set i [interp create -safe] 2360 proc parent {interp args} {interp hide $interp list} 2361} -body { 2362 $i alias parent parent $i 2363 set r [interp eval $i { 2364 namespace eval foo { 2365 proc list {args} { 2366 return "dummy foo::list" 2367 } 2368 parent 2369 } 2370 info commands list 2371 }] 2372} -cleanup { 2373 rename parent {} 2374 interp delete $i 2375} -result {} 2376test interp-28.2 {parent's nsName cache should not cross} -setup { 2377 set i [interp create] 2378 $i eval {proc filter lst {lsearch -all -inline -not $lst "::tcl"}} 2379} -body { 2380 $i eval { 2381 set x {namespace children ::} 2382 set y [list namespace children ::] 2383 namespace delete {*}[filter [{*}$y]] 2384 set j [interp create] 2385 $j alias filter filter 2386 $j eval {namespace delete {*}[filter [namespace children ::]]} 2387 namespace eval foo {} 2388 list [filter [eval $x]] [filter [eval $y]] [filter [$j eval $x]] [filter [$j eval $y]] 2389 } 2390} -cleanup { 2391 interp delete $i 2392} -result {::foo ::foo {} {}} 2393 2394# Part 29: recursion limit 2395# 29.1.* Argument checking 2396# 29.2.* Reading and setting the recursion limit 2397# 29.3.* Does the recursion limit work? 2398# 29.4.* Recursion limit inheritance by sub-interpreters 2399# 29.5.* Confirming the recursionlimit command does not affect the parent 2400# 29.6.* Safe interpreter restriction 2401 2402test interp-29.1.1 {interp recursionlimit argument checking} { 2403 list [catch {interp recursionlimit} msg] $msg 2404} {1 {wrong # args: should be "interp recursionlimit path ?newlimit?"}} 2405test interp-29.1.2 {interp recursionlimit argument checking} { 2406 list [catch {interp recursionlimit foo bar} msg] $msg 2407} {1 {could not find interpreter "foo"}} 2408test interp-29.1.3 {interp recursionlimit argument checking} { 2409 list [catch {interp recursionlimit foo bar baz} msg] $msg 2410} {1 {wrong # args: should be "interp recursionlimit path ?newlimit?"}} 2411test interp-29.1.4 {interp recursionlimit argument checking} { 2412 interp create moo 2413 set result [catch {interp recursionlimit moo bar} msg] 2414 interp delete moo 2415 list $result $msg 2416} {1 {expected integer but got "bar"}} 2417test interp-29.1.5 {interp recursionlimit argument checking} { 2418 interp create moo 2419 set result [catch {interp recursionlimit moo 0} msg] 2420 interp delete moo 2421 list $result $msg 2422} {1 {recursion limit must be > 0}} 2423test interp-29.1.6 {interp recursionlimit argument checking} { 2424 interp create moo 2425 set result [catch {interp recursionlimit moo -1} msg] 2426 interp delete moo 2427 list $result $msg 2428} {1 {recursion limit must be > 0}} 2429test interp-29.1.7 {interp recursionlimit argument checking} { 2430 interp create moo 2431 set result [catch {interp recursionlimit moo [expr {wide(1)<<32}]} msg] 2432 interp delete moo 2433 list $result [string range $msg 0 35] 2434} {1 {integer value too large to represent}} 2435test interp-29.1.8 {child recursionlimit argument checking} { 2436 interp create moo 2437 set result [catch {moo recursionlimit foo bar} msg] 2438 interp delete moo 2439 list $result $msg 2440} {1 {wrong # args: should be "moo recursionlimit ?newlimit?"}} 2441test interp-29.1.9 {child recursionlimit argument checking} { 2442 interp create moo 2443 set result [catch {moo recursionlimit foo} msg] 2444 interp delete moo 2445 list $result $msg 2446} {1 {expected integer but got "foo"}} 2447test interp-29.1.10 {child recursionlimit argument checking} { 2448 interp create moo 2449 set result [catch {moo recursionlimit 0} msg] 2450 interp delete moo 2451 list $result $msg 2452} {1 {recursion limit must be > 0}} 2453test interp-29.1.11 {child recursionlimit argument checking} { 2454 interp create moo 2455 set result [catch {moo recursionlimit -1} msg] 2456 interp delete moo 2457 list $result $msg 2458} {1 {recursion limit must be > 0}} 2459test interp-29.1.12 {child recursionlimit argument checking} { 2460 interp create moo 2461 set result [catch {moo recursionlimit [expr {wide(1)<<32}]} msg] 2462 interp delete moo 2463 list $result [string range $msg 0 35] 2464} {1 {integer value too large to represent}} 2465test interp-29.2.1 {query recursion limit} { 2466 interp recursionlimit {} 2467} 1000 2468test interp-29.2.2 {query recursion limit} { 2469 set i [interp create] 2470 set n [interp recursionlimit $i] 2471 interp delete $i 2472 set n 2473} 1000 2474test interp-29.2.3 {query recursion limit} { 2475 set i [interp create] 2476 set n [$i recursionlimit] 2477 interp delete $i 2478 set n 2479} 1000 2480test interp-29.2.4 {query recursion limit} { 2481 set i [interp create] 2482 set r [$i eval { 2483 set n1 [interp recursionlimit {} 42] 2484 set n2 [interp recursionlimit {}] 2485 list $n1 $n2 2486 }] 2487 interp delete $i 2488 set r 2489} {42 42} 2490test interp-29.2.5 {query recursion limit} { 2491 set i [interp create] 2492 set n1 [interp recursionlimit $i 42] 2493 set n2 [interp recursionlimit $i] 2494 interp delete $i 2495 list $n1 $n2 2496} {42 42} 2497test interp-29.2.6 {query recursion limit} { 2498 set i [interp create] 2499 set n1 [interp recursionlimit $i 42] 2500 set n2 [$i recursionlimit] 2501 interp delete $i 2502 list $n1 $n2 2503} {42 42} 2504test interp-29.2.7 {query recursion limit} { 2505 set i [interp create] 2506 set n1 [$i recursionlimit 42] 2507 set n2 [interp recursionlimit $i] 2508 interp delete $i 2509 list $n1 $n2 2510} {42 42} 2511test interp-29.2.8 {query recursion limit} { 2512 set i [interp create] 2513 set n1 [$i recursionlimit 42] 2514 set n2 [$i recursionlimit] 2515 interp delete $i 2516 list $n1 $n2 2517} {42 42} 2518test interp-29.3.1 {recursion limit} { 2519 set i [interp create] 2520 set r [interp eval $i { 2521 interp recursionlimit {} 50 2522 proc p {} {incr ::i; p} 2523 set i 0 2524 list [catch p msg] $msg $i 2525 }] 2526 interp delete $i 2527 set r 2528} {1 {too many nested evaluations (infinite loop?)} 49} 2529test interp-29.3.2 {recursion limit} { 2530 set i [interp create] 2531 interp recursionlimit $i 50 2532 set r [interp eval $i { 2533 proc p {} {incr ::i; p} 2534 set i 0 2535 list [catch p msg] $msg $i 2536 }] 2537 interp delete $i 2538 set r 2539} {1 {too many nested evaluations (infinite loop?)} 49} 2540test interp-29.3.3 {recursion limit} { 2541 set i [interp create] 2542 $i recursionlimit 50 2543 set r [interp eval $i { 2544 proc p {} {incr ::i; p} 2545 set i 0 2546 list [catch p msg] $msg $i 2547 }] 2548 interp delete $i 2549 set r 2550} {1 {too many nested evaluations (infinite loop?)} 49} 2551test interp-29.3.4 {recursion limit error reporting} { 2552 interp create child 2553 set r1 [child eval { 2554 catch { # nesting level 1 2555 eval { # 2 2556 eval { # 3 2557 eval { # 4 2558 eval { # 5 2559 interp recursionlimit {} 5 2560 set x ok 2561 } 2562 } 2563 } 2564 } 2565 } msg 2566 }] 2567 set r2 [child eval { set msg }] 2568 interp delete child 2569 list $r1 $r2 2570} {1 {falling back due to new recursion limit}} 2571test interp-29.3.5 {recursion limit error reporting} { 2572 interp create child 2573 set r1 [child eval { 2574 catch { # nesting level 1 2575 eval { # 2 2576 eval { # 3 2577 eval { # 4 2578 eval { # 5 2579 interp recursionlimit {} 4 2580 set x ok 2581 } 2582 } 2583 } 2584 } 2585 } msg 2586 }] 2587 set r2 [child eval { set msg }] 2588 interp delete child 2589 list $r1 $r2 2590} {1 {falling back due to new recursion limit}} 2591test interp-29.3.6 {recursion limit error reporting} { 2592 interp create child 2593 set r1 [child eval { 2594 catch { # nesting level 1 2595 eval { # 2 2596 eval { # 3 2597 eval { # 4 2598 eval { # 5 2599 interp recursionlimit {} 6 2600 set x ok 2601 } 2602 } 2603 } 2604 } 2605 } msg 2606 }] 2607 set r2 [child eval { set msg }] 2608 interp delete child 2609 list $r1 $r2 2610} {0 ok} 2611# 2612# Note that TEBC does not verify the interp's nesting level itself; the nesting 2613# level will only be verified when it invokes a non-bcc'd command. 2614# 2615test interp-29.3.7a {recursion limit error reporting} { 2616 interp create child 2617 after 0 {interp recursionlimit child 5} 2618 set r1 [child eval { 2619 catch { # nesting level 1 2620 eval { # 2 2621 eval { # 3 2622 eval { # 4 2623 eval { # 5 2624 update 2625 set x ok 2626 } 2627 } 2628 } 2629 } 2630 } msg 2631 }] 2632 set r2 [child eval { set msg }] 2633 interp delete child 2634 list $r1 $r2 2635} {0 ok} 2636test interp-29.3.7b {recursion limit error reporting} { 2637 interp create child 2638 after 0 {interp recursionlimit child 5} 2639 set r1 [child eval { 2640 catch { # nesting level 1 2641 eval { # 2 2642 eval { # 3 2643 eval { # 4 2644 update 2645 eval { # 5 2646 set x ok 2647 } 2648 } 2649 } 2650 } 2651 } msg 2652 }] 2653 set r2 [child eval { set msg }] 2654 interp delete child 2655 list $r1 $r2 2656} {0 ok} 2657test interp-29.3.7c {recursion limit error reporting} { 2658 interp create child 2659 after 0 {interp recursionlimit child 5} 2660 set r1 [child eval { 2661 catch { # nesting level 1 2662 eval { # 2 2663 eval { # 3 2664 eval { # 4 2665 eval { # 5 2666 update 2667 set set set 2668 $set x ok 2669 } 2670 } 2671 } 2672 } 2673 } msg 2674 }] 2675 set r2 [child eval { set msg }] 2676 interp delete child 2677 list $r1 $r2 2678} {1 {too many nested evaluations (infinite loop?)}} 2679test interp-29.3.8a {recursion limit error reporting} { 2680 interp create child 2681 after 0 {interp recursionlimit child 4} 2682 set r1 [child eval { 2683 catch { # nesting level 1 2684 eval { # 2 2685 eval { # 3 2686 eval { # 4 2687 eval { # 5 2688 update 2689 set x ok 2690 } 2691 } 2692 } 2693 } 2694 } msg 2695 }] 2696 set r2 [child eval { set msg }] 2697 interp delete child 2698 list $r1 $r2 2699} {0 ok} 2700test interp-29.3.8b {recursion limit error reporting} { 2701 interp create child 2702 after 0 {interp recursionlimit child 4} 2703 set r1 [child eval { 2704 catch { # nesting level 1 2705 eval { # 2 2706 eval { # 3 2707 eval { # 4 2708 update 2709 eval { # 5 2710 set x ok 2711 } 2712 } 2713 } 2714 } 2715 } msg 2716 }] 2717 set r2 [child eval { set msg }] 2718 interp delete child 2719 list $r1 $r2 2720} {1 {too many nested evaluations (infinite loop?)}} 2721test interp-29.3.9a {recursion limit error reporting} { 2722 interp create child 2723 after 0 {interp recursionlimit child 6} 2724 set r1 [child eval { 2725 catch { # nesting level 1 2726 eval { # 2 2727 eval { # 3 2728 eval { # 4 2729 eval { # 5 2730 update 2731 set x ok 2732 } 2733 } 2734 } 2735 } 2736 } msg 2737 }] 2738 set r2 [child eval { set msg }] 2739 interp delete child 2740 list $r1 $r2 2741} {0 ok} 2742test interp-29.3.9b {recursion limit error reporting} { 2743 interp create child 2744 after 0 {interp recursionlimit child 6} 2745 set r1 [child eval { 2746 catch { # nesting level 1 2747 eval { # 2 2748 eval { # 3 2749 eval { # 4 2750 eval { # 5 2751 set set set 2752 $set x ok 2753 } 2754 } 2755 } 2756 } 2757 } msg 2758 }] 2759 set r2 [child eval { set msg }] 2760 interp delete child 2761 list $r1 $r2 2762} {0 ok} 2763test interp-29.3.10a {recursion limit error reporting} { 2764 interp create child 2765 after 0 {child recursionlimit 4} 2766 set r1 [child eval { 2767 catch { # nesting level 1 2768 eval { # 2 2769 eval { # 3 2770 eval { # 4 2771 eval { # 5 2772 update 2773 set x ok 2774 } 2775 } 2776 } 2777 } 2778 } msg 2779 }] 2780 set r2 [child eval { set msg }] 2781 interp delete child 2782 list $r1 $r2 2783} {0 ok} 2784test interp-29.3.10b {recursion limit error reporting} { 2785 interp create child 2786 after 0 {child recursionlimit 4} 2787 set r1 [child eval { 2788 catch { # nesting level 1 2789 eval { # 2 2790 eval { # 3 2791 eval { # 4 2792 update 2793 eval { # 5 2794 set x ok 2795 } 2796 } 2797 } 2798 } 2799 } msg 2800 }] 2801 set r2 [child eval { set msg }] 2802 interp delete child 2803 list $r1 $r2 2804} {1 {too many nested evaluations (infinite loop?)}} 2805test interp-29.3.11a {recursion limit error reporting} { 2806 interp create child 2807 after 0 {child recursionlimit 5} 2808 set r1 [child eval { 2809 catch { # nesting level 1 2810 eval { # 2 2811 eval { # 3 2812 eval { # 4 2813 eval { # 5 2814 update 2815 set x ok 2816 } 2817 } 2818 } 2819 } 2820 } msg 2821 }] 2822 set r2 [child eval { set msg }] 2823 interp delete child 2824 list $r1 $r2 2825} {0 ok} 2826test interp-29.3.11b {recursion limit error reporting} { 2827 interp create child 2828 after 0 {child recursionlimit 5} 2829 set r1 [child eval { 2830 catch { # nesting level 1 2831 eval { # 2 2832 eval { # 3 2833 eval { # 4 2834 eval { # 5 2835 update 2836 set set set 2837 $set x ok 2838 } 2839 } 2840 } 2841 } 2842 } msg 2843 }] 2844 set r2 [child eval { set msg }] 2845 interp delete child 2846 list $r1 $r2 2847} {1 {too many nested evaluations (infinite loop?)}} 2848test interp-29.3.12a {recursion limit error reporting} { 2849 interp create child 2850 after 0 {child recursionlimit 6} 2851 set r1 [child eval { 2852 catch { # nesting level 1 2853 eval { # 2 2854 eval { # 3 2855 eval { # 4 2856 eval { # 5 2857 update 2858 set x ok 2859 } 2860 } 2861 } 2862 } 2863 } msg 2864 }] 2865 set r2 [child eval { set msg }] 2866 interp delete child 2867 list $r1 $r2 2868} {0 ok} 2869test interp-29.3.12b {recursion limit error reporting} { 2870 interp create child 2871 after 0 {child recursionlimit 6} 2872 set r1 [child eval { 2873 catch { # nesting level 1 2874 eval { # 2 2875 eval { # 3 2876 eval { # 4 2877 eval { # 5 2878 update 2879 set set set 2880 $set x ok 2881 } 2882 } 2883 } 2884 } 2885 } msg 2886 }] 2887 set r2 [child eval { set msg }] 2888 interp delete child 2889 list $r1 $r2 2890} {0 ok} 2891test interp-29.4.1 {recursion limit inheritance} { 2892 set i [interp create] 2893 set ii [interp eval $i { 2894 interp recursionlimit {} 50 2895 interp create 2896 }] 2897 set r [interp eval [list $i $ii] { 2898 proc p {} {incr ::i; p} 2899 set i 0 2900 catch p 2901 set i 2902 }] 2903 interp delete $i 2904 set r 2905} 50 2906test interp-29.4.2 {recursion limit inheritance} { 2907 set i [interp create] 2908 $i recursionlimit 50 2909 set ii [interp eval $i {interp create}] 2910 set r [interp eval [list $i $ii] { 2911 proc p {} {incr ::i; p} 2912 set i 0 2913 catch p 2914 set i 2915 }] 2916 interp delete $i 2917 set r 2918} 50 2919test interp-29.5.1 {does child recursion limit affect parent?} { 2920 set before [interp recursionlimit {}] 2921 set i [interp create] 2922 interp recursionlimit $i 20000 2923 set after [interp recursionlimit {}] 2924 set childlimit [interp recursionlimit $i] 2925 interp delete $i 2926 list [expr {$before == $after}] $childlimit 2927} {1 20000} 2928test interp-29.5.2 {does child recursion limit affect parent?} { 2929 set before [interp recursionlimit {}] 2930 set i [interp create] 2931 interp recursionlimit $i 20000 2932 set after [interp recursionlimit {}] 2933 set childlimit [$i recursionlimit] 2934 interp delete $i 2935 list [expr {$before == $after}] $childlimit 2936} {1 20000} 2937test interp-29.5.3 {does child recursion limit affect parent?} { 2938 set before [interp recursionlimit {}] 2939 set i [interp create] 2940 $i recursionlimit 20000 2941 set after [interp recursionlimit {}] 2942 set childlimit [interp recursionlimit $i] 2943 interp delete $i 2944 list [expr {$before == $after}] $childlimit 2945} {1 20000} 2946test interp-29.5.4 {does child recursion limit affect parent?} { 2947 set before [interp recursionlimit {}] 2948 set i [interp create] 2949 $i recursionlimit 20000 2950 set after [interp recursionlimit {}] 2951 set childlimit [$i recursionlimit] 2952 interp delete $i 2953 list [expr {$before == $after}] $childlimit 2954} {1 20000} 2955test interp-29.6.1 {safe interpreter recursion limit} { 2956 interp create child -safe 2957 set n [interp recursionlimit child] 2958 interp delete child 2959 set n 2960} 1000 2961test interp-29.6.2 {safe interpreter recursion limit} { 2962 interp create child -safe 2963 set n [child recursionlimit] 2964 interp delete child 2965 set n 2966} 1000 2967test interp-29.6.3 {safe interpreter recursion limit} { 2968 interp create child -safe 2969 set n1 [interp recursionlimit child 42] 2970 set n2 [interp recursionlimit child] 2971 interp delete child 2972 list $n1 $n2 2973} {42 42} 2974test interp-29.6.4 {safe interpreter recursion limit} { 2975 interp create child -safe 2976 set n1 [child recursionlimit 42] 2977 set n2 [interp recursionlimit child] 2978 interp delete child 2979 list $n1 $n2 2980} {42 42} 2981test interp-29.6.5 {safe interpreter recursion limit} { 2982 interp create child -safe 2983 set n1 [interp recursionlimit child 42] 2984 set n2 [child recursionlimit] 2985 interp delete child 2986 list $n1 $n2 2987} {42 42} 2988test interp-29.6.6 {safe interpreter recursion limit} { 2989 interp create child -safe 2990 set n1 [child recursionlimit 42] 2991 set n2 [child recursionlimit] 2992 interp delete child 2993 list $n1 $n2 2994} {42 42} 2995test interp-29.6.7 {safe interpreter recursion limit} { 2996 interp create child -safe 2997 set n1 [child recursionlimit 42] 2998 set n2 [child recursionlimit] 2999 interp delete child 3000 list $n1 $n2 3001} {42 42} 3002test interp-29.6.8 {safe interpreter recursion limit} { 3003 interp create child -safe 3004 set n [catch {child eval {interp recursionlimit {} 42}} msg] 3005 interp delete child 3006 list $n $msg 3007} {1 {permission denied: safe interpreters cannot change recursion limit}} 3008test interp-29.6.9 {safe interpreter recursion limit} { 3009 interp create child -safe 3010 set result [ 3011 child eval { 3012 interp create child2 -safe 3013 set n [catch { 3014 interp recursionlimit child2 42 3015 } msg] 3016 list $n $msg 3017 } 3018 ] 3019 interp delete child 3020 set result 3021} {1 {permission denied: safe interpreters cannot change recursion limit}} 3022test interp-29.6.10 {safe interpreter recursion limit} { 3023 interp create child -safe 3024 set result [ 3025 child eval { 3026 interp create child2 -safe 3027 set n [catch { 3028 child2 recursionlimit 42 3029 } msg] 3030 list $n $msg 3031 } 3032 ] 3033 interp delete child 3034 set result 3035} {1 {permission denied: safe interpreters cannot change recursion limit}} 3036 3037 3038# # Deep recursion (into interps when the regular one fails): 3039# # still crashes... 3040# proc p {} { 3041# if {[catch p ret]} { 3042# catch { 3043# set i [interp create] 3044# interp eval $i [list proc p {} [info body p]] 3045# interp eval $i p 3046# } 3047# interp delete $i 3048# return ok 3049# } 3050# return $ret 3051# } 3052# p 3053 3054# more tests needed... 3055 3056# Interp & stack 3057#test interp-29.1 {interp and stack (info level)} { 3058#} {} 3059 3060# End of stack-recursion tests 3061 3062# This test dumps core in Tcl 8.0.3! 3063test interp-30.1 {deletion of aliases inside namespaces} { 3064 set i [interp create] 3065 $i alias ns::cmd list 3066 $i alias ns::cmd {} 3067} {} 3068 3069test interp-31.1 {alias invocation scope} { 3070 proc mySet {varName value} { 3071 upvar 1 $varName localVar 3072 set localVar $value 3073 } 3074 interp alias {} myNewSet {} mySet 3075 proc testMyNewSet {value} { 3076 myNewSet a $value 3077 return $a 3078 } 3079 unset -nocomplain a 3080 set result [testMyNewSet "ok"] 3081 rename testMyNewSet {} 3082 rename mySet {} 3083 rename myNewSet {} 3084 set result 3085} ok 3086 3087test interp-32.1 {parent's working directory should be inherited by a child interp} -setup { 3088 cd [temporaryDirectory] 3089} -body { 3090 set parent [pwd] 3091 set i [interp create] 3092 set child [$i eval pwd] 3093 interp delete $i 3094 file mkdir cwd_test 3095 cd cwd_test 3096 lappend parent [pwd] 3097 set i [interp create] 3098 lappend child [$i eval pwd] 3099 cd .. 3100 file delete cwd_test 3101 interp delete $i 3102 expr {[string equal $parent $child] ? 1 : 3103 "\{$parent\} != \{$child\}"} 3104} -cleanup { 3105 cd [workingDirectory] 3106} -result 1 3107 3108test interp-33.1 {refCounting for target words of alias [Bug 730244]} { 3109 # This test will panic if Bug 730244 is not fixed. 3110 set i [interp create] 3111 proc testHelper args {rename testHelper {}; return $args} 3112 # Note: interp names are simple words by default 3113 trace add execution testHelper enter "interp alias $i alias {} ;#" 3114 interp alias $i alias {} testHelper this 3115 $i eval alias 3116} this 3117 3118test interp-34.1 {basic test of limits - calling commands} -body { 3119 set i [interp create] 3120 $i eval { 3121 proc foobar {} { 3122 for {set x 0} {$x<1000000} {incr x} { 3123 # Calls to this are not bytecoded away 3124 pid 3125 } 3126 } 3127 } 3128 $i limit command -value 1000 3129 $i eval foobar 3130} -returnCodes error -result {command count limit exceeded} -cleanup { 3131 interp delete $i 3132} 3133test interp-34.2 {basic test of limits - bytecoded commands} -body { 3134 set i [interp create] 3135 $i eval { 3136 proc foobar {} { 3137 for {set x 0} {$x<1000000} {incr x} { 3138 # Calls to this *are* bytecoded away 3139 expr {1+2+3} 3140 } 3141 } 3142 } 3143 $i limit command -value 1000 3144 $i eval foobar 3145} -returnCodes error -result {command count limit exceeded} -cleanup { 3146 interp delete $i 3147} 3148test interp-34.3 {basic test of limits - pure bytecode loop} -body { 3149 set i [interp create] 3150 $i eval { 3151 proc foobar {} { 3152 while {1} { 3153 # No bytecode at all here... 3154 } 3155 } 3156 } 3157 # We use a time limit here; command limits don't trap this case 3158 $i limit time -seconds [expr {[clock seconds]+2}] 3159 $i eval foobar 3160} -returnCodes error -result {time limit exceeded} -cleanup { 3161 interp delete $i 3162} 3163test interp-34.3.1 {basic test of limits - pure inside-command loop} -body { 3164 set i [interp create] 3165 $i eval { 3166 proc foobar {} { 3167 set while while 3168 $while {1} { 3169 # No bytecode at all here... 3170 } 3171 } 3172 } 3173 # We use a time limit here; command limits don't trap this case 3174 $i limit time -seconds [expr {[clock seconds] + 2}] 3175 $i eval foobar 3176} -returnCodes error -result {time limit exceeded} -cleanup { 3177 interp delete $i 3178} 3179test interp-34.4 {limits with callbacks: extending limits} -setup { 3180 set i [interp create] 3181 set a 0 3182 set b 0 3183 set c a 3184 proc cb1 {} { 3185 global c 3186 incr ::$c 3187 } 3188 proc cb2 {newlimit args} { 3189 global c i 3190 set c b 3191 $i limit command -value $newlimit 3192 } 3193} -body { 3194 interp alias $i foo {} cb1 3195 set curlim [$i eval info cmdcount] 3196 $i limit command -command "cb2 [expr {$curlim + 100}]" \ 3197 -value [expr {$curlim + 10}] 3198 $i eval {for {set i 0} {$i<10} {incr i} {foo}} 3199 list $a $b $c 3200} -result {6 4 b} -cleanup { 3201 interp delete $i 3202 rename cb1 {} 3203 rename cb2 {} 3204} 3205# The next three tests exercise all the three ways that limit handlers 3206# can be deleted. Fully verifying this requires additional source 3207# code instrumentation. 3208test interp-34.5 {limits with callbacks: removing limits} -setup { 3209 set i [interp create] 3210 set a 0 3211 set b 0 3212 set c a 3213 proc cb1 {} { 3214 global c 3215 incr ::$c 3216 } 3217 proc cb2 {newlimit args} { 3218 global c i 3219 set c b 3220 $i limit command -value $newlimit 3221 } 3222} -body { 3223 interp alias $i foo {} cb1 3224 set curlim [$i eval info cmdcount] 3225 $i limit command -command "cb2 {}" -value [expr {$curlim + 10}] 3226 $i eval {for {set i 0} {$i<10} {incr i} {foo}} 3227 list $a $b $c 3228} -result {6 4 b} -cleanup { 3229 interp delete $i 3230 rename cb1 {} 3231 rename cb2 {} 3232} 3233test interp-34.6 {limits with callbacks: removing limits and handlers} -setup { 3234 set i [interp create] 3235 set a 0 3236 set b 0 3237 set c a 3238 proc cb1 {} { 3239 global c 3240 incr ::$c 3241 } 3242 proc cb2 {args} { 3243 global c i 3244 set c b 3245 $i limit command -value {} -command {} 3246 } 3247} -body { 3248 interp alias $i foo {} cb1 3249 set curlim [$i eval info cmdcount] 3250 $i limit command -command cb2 -value [expr {$curlim + 10}] 3251 $i eval {for {set i 0} {$i<10} {incr i} {foo}} 3252 list $a $b $c 3253} -result {6 4 b} -cleanup { 3254 interp delete $i 3255 rename cb1 {} 3256 rename cb2 {} 3257} 3258test interp-34.7 {limits with callbacks: deleting the handler interp} -setup { 3259 set i [interp create] 3260 $i eval { 3261 set i [interp create] 3262 proc cb1 {} { 3263 global c 3264 incr ::$c 3265 } 3266 proc cb2 {args} { 3267 global c i curlim 3268 set c b 3269 $i limit command -value [expr {$curlim + 1000}] 3270 trapToParent 3271 } 3272 } 3273 proc cb3 {} { 3274 global i subi 3275 interp alias [list $i $subi] foo {} cb4 3276 interp delete $i 3277 } 3278 proc cb4 {} { 3279 global n 3280 incr n 3281 } 3282} -body { 3283 set subi [$i eval set i] 3284 interp alias $i trapToParent {} cb3 3285 set n 0 3286 $i eval { 3287 set a 0 3288 set b 0 3289 set c a 3290 interp alias $i foo {} cb1 3291 set curlim [$i eval info cmdcount] 3292 $i limit command -command cb2 -value [expr {$curlim + 10}] 3293 } 3294 $i eval { 3295 $i eval { 3296 for {set i 0} {$i<10} {incr i} {foo} 3297 } 3298 } 3299 list $n [interp exists $i] 3300} -result {4 0} -cleanup { 3301 rename cb3 {} 3302 rename cb4 {} 3303} 3304# Bug 1085023 3305test interp-34.8 {time limits trigger in vwaits} -body { 3306 set i [interp create] 3307 interp limit $i time -seconds [expr {[clock seconds] + 1}] -granularity 1 3308 $i eval { 3309 set x {} 3310 vwait x 3311 } 3312} -cleanup { 3313 interp delete $i 3314} -returnCodes error -result {limit exceeded} 3315test interp-34.9 {time limits trigger in blocking after} { 3316 set i [interp create] 3317 set t0 [clock seconds] 3318 interp limit $i time -seconds [expr {$t0 + 1}] -granularity 1 3319 set code [catch { 3320 $i eval {after 10000} 3321 } msg] 3322 set t1 [clock seconds] 3323 interp delete $i 3324 list $code $msg [expr {($t1-$t0) < 3 ? "OK" : $t1-$t0}] 3325} {1 {time limit exceeded} OK} 3326test interp-34.10 {time limits trigger in vwaits: Bug 1221395} -body { 3327 set i [interp create] 3328 # Assume someone hasn't set the clock to early 1970! 3329 $i limit time -seconds 1 -granularity 4 3330 interp alias $i log {} lappend result 3331 set result {} 3332 catch { 3333 $i eval { 3334 log 1 3335 after 100 3336 log 2 3337 } 3338 } msg 3339 interp delete $i 3340 lappend result $msg 3341} -result {1 {time limit exceeded}} 3342test interp-34.11 {time limit extension in callbacks} -setup { 3343 proc cb1 {i t} { 3344 global result 3345 lappend result cb1 3346 $i limit time -seconds $t -command cb2 3347 } 3348 proc cb2 {} { 3349 global result 3350 lappend result cb2 3351 } 3352} -body { 3353 set i [interp create] 3354 set t0 [clock seconds] 3355 $i limit time -seconds [expr {$t0 + 1}] -granularity 1 \ 3356 -command "cb1 $i [expr {$t0 + 2}]" 3357 set ::result {} 3358 lappend ::result [catch { 3359 $i eval { 3360 for {set i 0} {$i<30} {incr i} { 3361 after 100 3362 } 3363 } 3364 } msg] $msg 3365 set t1 [clock seconds] 3366 lappend ::result [expr {$t1-$t0>=2 ? "ok" : "$t0,$t1"}] 3367 interp delete $i 3368 return $::result 3369} -result {cb1 cb2 1 {time limit exceeded} ok} -cleanup { 3370 rename cb1 {} 3371 rename cb2 {} 3372} 3373test interp-34.12 {time limit extension in callbacks} -setup { 3374 proc cb1 {i} { 3375 global result times 3376 lappend result cb1 3377 set times [lassign $times t] 3378 $i limit time -seconds $t 3379 } 3380} -body { 3381 set i [interp create] 3382 set t0 [clock seconds] 3383 set ::times "[expr {$t0 + 2}] [expr {$t0 + 100}]" 3384 $i limit time -seconds [expr {$t0 + 1}] -granularity 1 -command "cb1 $i" 3385 set ::result {} 3386 lappend ::result [catch { 3387 $i eval { 3388 for {set i 0} {$i<30} {incr i} { 3389 after 100 3390 } 3391 } 3392 } msg] $msg 3393 set t1 [clock seconds] 3394 lappend ::result [expr {$t1-$t0>=2 ? "ok" : "$t0,$t1"}] 3395 interp delete $i 3396 return $::result 3397} -result {cb1 cb1 0 {} ok} -cleanup { 3398 rename cb1 {} 3399} 3400test interp-34.13 {time limit granularity and vwait: Bug 2891362} -setup { 3401 set i [interp create -safe] 3402} -body { 3403 $i limit time -seconds [clock add [clock seconds] 1 second] 3404 $i eval { 3405 after 2000 set x timeout 3406 vwait x 3407 return $x 3408 } 3409} -cleanup { 3410 interp delete $i 3411} -returnCodes error -result {limit exceeded} 3412 3413test interp-35.1 {interp limit syntax} -body { 3414 interp limit 3415} -returnCodes error -result {wrong # args: should be "interp limit path limitType ?-option value ...?"} 3416test interp-35.2 {interp limit syntax} -body { 3417 interp limit {} 3418} -returnCodes error -result {wrong # args: should be "interp limit path limitType ?-option value ...?"} 3419test interp-35.3 {interp limit syntax} -body { 3420 interp limit {} foo 3421} -returnCodes error -result {bad limit type "foo": must be commands or time} 3422test interp-35.4 {interp limit syntax} -body { 3423 set i [interp create] 3424 set dict [interp limit $i commands] 3425 set result {} 3426 foreach key [lsort [dict keys $dict]] { 3427 lappend result $key [dict get $dict $key] 3428 } 3429 set result 3430} -cleanup { 3431 interp delete $i 3432} -result {-command {} -granularity 1 -value {}} 3433test interp-35.5 {interp limit syntax} -body { 3434 set i [interp create] 3435 interp limit $i commands -granularity 3436} -cleanup { 3437 interp delete $i 3438} -result 1 3439test interp-35.6 {interp limit syntax} -body { 3440 set i [interp create] 3441 interp limit $i commands -granularity 2 3442} -cleanup { 3443 interp delete $i 3444} -result {} 3445test interp-35.7 {interp limit syntax} -body { 3446 set i [interp create] 3447 interp limit $i commands -foobar 3448} -cleanup { 3449 interp delete $i 3450} -returnCodes error -result {bad option "-foobar": must be -command, -granularity, or -value} 3451test interp-35.8 {interp limit syntax} -body { 3452 set i [interp create] 3453 interp limit $i commands -granularity foobar 3454} -cleanup { 3455 interp delete $i 3456} -returnCodes error -result {expected integer but got "foobar"} 3457test interp-35.9 {interp limit syntax} -body { 3458 set i [interp create] 3459 interp limit $i commands -granularity 0 3460} -cleanup { 3461 interp delete $i 3462} -returnCodes error -result {granularity must be at least 1} 3463test interp-35.10 {interp limit syntax} -body { 3464 set i [interp create] 3465 interp limit $i commands -value foobar 3466} -cleanup { 3467 interp delete $i 3468} -returnCodes error -result {expected integer but got "foobar"} 3469test interp-35.11 {interp limit syntax} -body { 3470 set i [interp create] 3471 interp limit $i commands -value -1 3472} -cleanup { 3473 interp delete $i 3474} -returnCodes error -result {command limit value must be at least 0} 3475test interp-35.12 {interp limit syntax} -body { 3476 set i [interp create] 3477 set dict [interp limit $i time] 3478 set result {} 3479 foreach key [lsort [dict keys $dict]] { 3480 lappend result $key [dict get $dict $key] 3481 } 3482 set result 3483} -cleanup { 3484 interp delete $i 3485} -result {-command {} -granularity 10 -milliseconds {} -seconds {}} 3486test interp-35.13 {interp limit syntax} -body { 3487 set i [interp create] 3488 interp limit $i time -granularity 3489} -cleanup { 3490 interp delete $i 3491} -result 10 3492test interp-35.14 {interp limit syntax} -body { 3493 set i [interp create] 3494 interp limit $i time -granularity 2 3495} -cleanup { 3496 interp delete $i 3497} -result {} 3498test interp-35.15 {interp limit syntax} -body { 3499 set i [interp create] 3500 interp limit $i time -foobar 3501} -cleanup { 3502 interp delete $i 3503} -returnCodes error -result {bad option "-foobar": must be -command, -granularity, -milliseconds, or -seconds} 3504test interp-35.16 {interp limit syntax} -body { 3505 set i [interp create] 3506 interp limit $i time -granularity foobar 3507} -cleanup { 3508 interp delete $i 3509} -returnCodes error -result {expected integer but got "foobar"} 3510test interp-35.17 {interp limit syntax} -body { 3511 set i [interp create] 3512 interp limit $i time -granularity 0 3513} -cleanup { 3514 interp delete $i 3515} -returnCodes error -result {granularity must be at least 1} 3516test interp-35.18 {interp limit syntax} -body { 3517 set i [interp create] 3518 interp limit $i time -seconds foobar 3519} -cleanup { 3520 interp delete $i 3521} -returnCodes error -result {expected integer but got "foobar"} 3522test interp-35.19 {interp limit syntax} -body { 3523 set i [interp create] 3524 interp limit $i time -seconds -1 3525} -cleanup { 3526 interp delete $i 3527} -match glob -returnCodes error -result {seconds must be between 0 and *} 3528test interp-35.20 {interp limit syntax} -body { 3529 set i [interp create] 3530 interp limit $i time -millis foobar 3531} -cleanup { 3532 interp delete $i 3533} -returnCodes error -result {expected integer but got "foobar"} 3534test interp-35.21 {interp limit syntax} -body { 3535 set i [interp create] 3536 interp limit $i time -millis -1 3537} -cleanup { 3538 interp delete $i 3539} -match glob -returnCodes error -result {milliseconds must be between 0 and *} 3540test interp-35.22 {interp time limits normalize milliseconds} -body { 3541 set i [interp create] 3542 interp limit $i time -seconds 1 -millis 1500 3543 list [$i limit time -seconds] [$i limit time -millis] 3544} -cleanup { 3545 interp delete $i 3546} -result {2 500} 3547# Bug 3398794 3548test interp-35.23 {interp command limits can't touch current interp} -body { 3549 interp limit {} commands -value 10 3550} -returnCodes error -result {limits on current interpreter inaccessible} 3551test interp-35.24 {interp time limits can't touch current interp} -body { 3552 interp limit {} time -seconds 2 3553} -returnCodes error -result {limits on current interpreter inaccessible} 3554 3555test interp-36.1 {interp bgerror syntax} -body { 3556 interp bgerror 3557} -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"} 3558test interp-36.2 {interp bgerror syntax} -body { 3559 interp bgerror x y z 3560} -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"} 3561test interp-36.3 {interp bgerror syntax} -setup { 3562 interp create child 3563} -body { 3564 child bgerror x y 3565} -cleanup { 3566 interp delete child 3567} -returnCodes error -result {wrong # args: should be "child bgerror ?cmdPrefix?"} 3568test interp-36.4 {ChildBgerror syntax} -setup { 3569 interp create child 3570} -body { 3571 child bgerror \{ 3572} -cleanup { 3573 interp delete child 3574} -returnCodes error -result {cmdPrefix must be list of length >= 1} 3575test interp-36.5 {ChildBgerror syntax} -setup { 3576 interp create child 3577} -body { 3578 child bgerror {} 3579} -cleanup { 3580 interp delete child 3581} -returnCodes error -result {cmdPrefix must be list of length >= 1} 3582test interp-36.6 {ChildBgerror returns handler} -setup { 3583 interp create child 3584} -body { 3585 child bgerror {foo bar soom} 3586} -cleanup { 3587 interp delete child 3588} -result {foo bar soom} 3589test interp-36.7 {ChildBgerror sets error handler of child [1999035]} -setup { 3590 interp create child 3591 child alias handler handler 3592 child bgerror handler 3593 variable result {untouched} 3594 proc handler {args} { 3595 variable result 3596 set result [lindex $args 0] 3597 } 3598} -body { 3599 child eval { 3600 variable done {} 3601 after 0 error foo 3602 after 10 [list ::set [namespace which -variable done] {}] 3603 vwait [namespace which -variable done] 3604 } 3605 set result 3606} -cleanup { 3607 variable result {} 3608 unset -nocomplain result 3609 interp delete child 3610} -result foo 3611 3612test interp-37.1 {safe interps and min() and max(): Bug 2895741} -setup { 3613 catch {interp delete a} 3614 interp create a 3615 set result {} 3616} -body { 3617 interp create {a b} -safe 3618 lappend result [interp eval a {expr {min(5,2,3)*max(7,13,11)}}] 3619 lappend result [interp eval {a b} {expr {min(5,2,3)*max(7,13,11)}}] 3620} -cleanup { 3621 unset -nocomplain result 3622 interp delete a 3623} -result {26 26} 3624 3625test interp-38.1 {interp debug one-way switch} -setup { 3626 catch {interp delete a} 3627 interp create a 3628 interp debug a -frame 1 3629} -body { 3630 # TIP #3xx interp debug frame is a one-way switch 3631 interp debug a -frame 0 3632} -cleanup { 3633 interp delete a 3634} -result {1} 3635test interp-38.2 {interp debug env var} -setup { 3636 catch {interp delete a} 3637 set ::env(TCL_INTERP_DEBUG_FRAME) 1 3638 interp create a 3639} -body { 3640 interp debug a 3641} -cleanup { 3642 unset -nocomplain ::env(TCL_INTERP_DEBUG_FRAME) 3643 interp delete a 3644} -result {-frame 1} 3645test interp-38.3 {interp debug wrong args} -body { 3646 interp debug 3647} -returnCodes { 3648 error 3649} -result {wrong # args: should be "interp debug path ?-frame ?bool??"} 3650test interp-38.4 {interp debug basic setup} -constraints {!singleTestInterp} -body { 3651 interp debug {} 3652} -result {-frame 0} 3653test interp-38.5 {interp debug basic setup} -constraints {!singleTestInterp} -body { 3654 interp debug {} -f 3655} -result {0} 3656test interp-38.6 {interp debug basic setup} -body { 3657 interp debug -frames 3658} -returnCodes error -result {could not find interpreter "-frames"} 3659test interp-38.7 {interp debug basic setup} -body { 3660 interp debug {} -frames 3661} -returnCodes error -result {bad debug option "-frames": must be -frame} 3662test interp-38.8 {interp debug basic setup} -body { 3663 interp debug {} -frame 0 bogus 3664} -returnCodes { 3665 error 3666} -result {wrong # args: should be "interp debug path ?-frame ?bool??"} 3667 3668# cleanup 3669unset -nocomplain hidden_cmds 3670foreach i [interp children] { 3671 interp delete $i 3672} 3673::tcltest::cleanupTests 3674return 3675 3676# Local Variables: 3677# mode: tcl 3678# fill-column: 78 3679# End: 3680