util/src/TclTk/tcl8.6.12/tests/interp.test

   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 (c) 1995-1996 Sun Microsystems, Inc.
   8 # Copyright (c) 1998-1999 by 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
  13 if {"::tcltest" ni [namespace children]} {
  14     package require tcltest 2.1
  15     namespace import -force ::tcltest::*
  16 }
  17
  18 ::tcltest::loadTestedCommands
  19 catch [list package require -exact Tcltest [info patchlevel]]
  20
  21 testConstraint testinterpdelete [llength [info commands testinterpdelete]]
  22
  23 set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:encoding:dirs 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:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload}
  24
  25 foreach i [interp children] {
  26   interp delete $i
  27 }
  28 \f
  29 # Part 0: Check out options for interp command
  30 test interp-1.1 {options for interp command} -returnCodes error -body {
  31     interp
  32 } -result {wrong # args: should be "interp cmd ?arg ...?"}
  33 test 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, slaves, share, target, or transfer}
  36 test interp-1.3 {options for interp command} {
  37     interp delete
  38 } ""
  39 test interp-1.4 {options for interp command} -returnCodes error -body {
  40     interp delete foo bar
  41 } -result {could not find interpreter "foo"}
  42 test 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 #
  48 test 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?"}
  51 test 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, slaves, share, target, or transfer}
  54 test 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, slaves, share, target, or transfer}
  57 test 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, slaves, share, target, or transfer}
  60 test 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:
  65 test interp-2.1 {basic interpreter creation} {
  66     interp create a
  67 } a
  68 test interp-2.2 {basic interpreter creation} {
  69     catch {interp create}
  70 } 0
  71 test interp-2.3 {basic interpreter creation} {
  72     catch {interp create -safe}
  73 } 0
  74 test 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}
  79 test interp-2.5 {basic interpreter creation} {
  80     interp create b -safe
  81 } b
  82 test interp-2.6 {basic interpreter creation} {
  83     interp create d -safe
  84 } d
  85 test interp-2.7 {basic interpreter creation} {
  86     list [catch {interp create -froboz} msg] $msg
  87 } {1 {bad option "-froboz": must be -safe or --}}
  88 test interp-2.8 {basic interpreter creation} {
  89     interp create -- -froboz
  90 } -froboz
  91 test interp-2.9 {basic interpreter creation} {
  92     interp create -safe -- -froboz1
  93 } -froboz1
  94 test 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}
 101 test 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
 110 test 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
 119 test interp-2.13 {correct default when no $path arg is given} -body {
 120     interp create --
 121 } -match regexp -result {interp[0-9]+}
 122
 123 foreach i [interp children] {
 124     interp delete $i
 125 }
 126
 127 # Part 2: Testing "interp children" and "interp exists"
 128 test interp-3.1 {testing interp exists and interp children} {
 129     interp children
 130 } ""
 131 test interp-3.2 {testing interp exists and interp children} {
 132     interp create a
 133     interp exists a
 134 } 1
 135 test interp-3.3 {testing interp exists and interp children} {
 136     interp exists nonexistent
 137 } 0
 138 test 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?"}
 141 test 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?"}
 144 test interp-3.6 {testing interp exists and interp children} {
 145     interp exists
 146 } 1
 147 test interp-3.7 {testing interp exists and interp children} -setup {
 148     catch {interp create a}
 149 } -body {
 150     interp children
 151 } -result a
 152 test 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?"}
 155 test 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
 161 test 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"
 169 test interp-3.11 {testing interp delete} {
 170     interp delete
 171 } ""
 172 test interp-4.1 {testing interp delete} {
 173     catch {interp create a}
 174     interp delete a
 175 } ""
 176 test interp-4.2 {testing interp delete} -returnCodes error -body {
 177     interp delete nonexistent
 178 } -result {could not find interpreter "nonexistent"}
 179 test interp-4.3 {testing interp delete} -returnCodes error -body {
 180     interp delete x y z
 181 } -result {could not find interpreter "x"}
 182 test interp-4.4 {testing interp delete} {
 183     interp delete
 184 } ""
 185 test 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
 191 test 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 } ""
 197 test 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"}
 202 test interp-4.8 {testing interp delete} -returnCodes error -body {
 203     interp delete {}
 204 } -result {cannot delete the current interpreter}
 205
 206 foreach i [interp children] {
 207     interp delete $i
 208 }
 209
 210 # Part 4: Consistency checking - all nondeleted interpreters should be
 211 # there:
 212 test interp-5.1 {testing consistency} {
 213     interp children
 214 } ""
 215 test interp-5.2 {testing consistency} {
 216     interp exists a
 217 } 0
 218 test interp-5.3 {testing consistency} {
 219     interp exists nonexistent
 220 } 0
 221
 222 # Recreate interpreter "a"
 223 interp create a
 224
 225 # Part 5: Testing eval in interpreter object command and with interp command
 226 test interp-6.1 {testing eval} {
 227     a eval expr {{3 + 5}}
 228 } 8
 229 test interp-6.2 {testing eval} -returnCodes error -body {
 230     a eval foo
 231 } -result {invalid command name "foo"}
 232 test interp-6.3 {testing eval} {
 233     a eval {proc foo {} {expr {3 + 5}}}
 234     a eval foo
 235 } 8
 236 catch {a eval {proc foo {} {expr {3 + 5}}}}
 237 test interp-6.4 {testing eval} {
 238     interp eval a foo
 239 } 8
 240 test 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
 245 catch {interp create {a x2}}
 246 test 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:
 251 proc in_parent {args} {
 252      return [list seen in parent: $args]
 253 }
 254
 255 # Part 6: Testing basic alias creation
 256 test interp-7.1 {testing basic alias creation} {
 257     a alias foo in_parent
 258 } foo
 259 catch {a alias foo in_parent}
 260 test interp-7.2 {testing basic alias creation} {
 261     a alias bar in_parent a1 a2 a3
 262 } bar
 263 catch {a alias bar in_parent a1 a2 a3}
 264 # Test 6.3 has been deleted.
 265 test interp-7.3 {testing basic alias creation} {
 266     a alias foo
 267 } in_parent
 268 test interp-7.4 {testing basic alias creation} {
 269     a alias bar
 270 } {in_parent a1 a2 a3}
 271 test interp-7.5 {testing basic alias creation} {
 272     lsort [a aliases]
 273 } {bar foo}
 274 test 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
 279 test 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}}
 284 test 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}}
 289 test 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
 295 test 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"}}
 300 test 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!
 306 test 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"}}}
 318 test 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
 332 if {[info command nonexistent-command-in-parent] != ""} {
 333     rename nonexistent-command-in-parent {}
 334 }
 335
 336 # Part 9: Aliasing between interpreters
 337 test 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
 344 test 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}}
 353 test 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"}}
 361 test 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
 367 test 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
 377 test 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}}
 386 test 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"
 398 test interp-11.1 {testing interp target} {
 399     list [catch {interp target} msg] $msg
 400 } {1 {wrong # args: should be "interp target path alias"}}
 401 test interp-11.2 {testing interp target} {
 402     list [catch {interp target nosuchinterpreter foo} msg] $msg
 403 } {1 {could not find interpreter "nosuchinterpreter"}}
 404 test 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 } ""
 410 test 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}
 422 test 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}}
 434 test 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}}
 440 test 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"
 447 test interp-12.1 {testing interp issafe} {
 448     interp issafe
 449 } 0
 450 test interp-12.2 {testing interp issafe} {
 451     catch {interp delete a}
 452     interp create a
 453     interp issafe a
 454 } 0
 455 test 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
 461 test 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
 470 test interp-13.1 {testing foo issafe} {
 471     catch {interp delete a}
 472     interp create a
 473     a issafe
 474 } 0
 475 test 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
 481 test 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
 488 test 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
 494 test 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 ""
 501 test 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}
 509 test 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
 516 test 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} {}}
 522 test 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"}
 533 test 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"}
 549 test 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"}
 565 test 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"}
 576 test 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"}
 592 test 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
 609 test 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
 623 test 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"}}
 629 test 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 ""
 640 test 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"}}
 645 test 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 ""
 656 test 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}}
 662 test 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
 675 test 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 ""
 685 test 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 #
 701 proc kill {} {interp delete xxx}
 702 test 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 {}}
 708 test 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 {}}
 715 test 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 {}}
 722 test 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 } ""
 732 test 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 } ""
 743 test 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
 759 test 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}}
 762 test 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}}
 768 test 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}}
 774 test 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}}
 780 test 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}}
 787 test 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
 801 test interp-18.1 {testing Tcl_DeleteInterp vs children} testinterpdelete {
 802     list [catch {testinterpdelete} msg] $msg
 803 } {1 {wrong # args: should be "testinterpdelete path"}}
 804 test interp-18.2 {testing Tcl_DeleteInterp vs children} testinterpdelete {
 805     catch {interp delete a}
 806     interp create a
 807     testinterpdelete a
 808 } ""
 809 test 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 } ""
 815 test 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 } ""
 821 test 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 {}}
 829 test 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 {}}
 837 test 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}}
 853 test 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}}
 875 test 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}}
 880 test 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
 888 test 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 } {}
 896 test 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}
 903 test 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"}
 913 test 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"}
 922 test 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
 932 test 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}
 942 test 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 } {}
 952 test 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 {}}
 964 test 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
 976 test 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"}
 985 test 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}}
 996 test 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}}
1008 test 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}}
1020 test 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}}
1032 test 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}}
1043 test 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}}}
1051 test 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}}}
1060 test 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}}}
1070 test 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"}
1079 test 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}}
1090 test 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}}
1102 test 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}}
1114 test 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}}
1126 test 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}}
1140 test 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}}}
1151 test 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}}}
1163 test 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}}}
1175 test 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}
1183 test 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}
1191 test 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 {}}
1200 test 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 {}}
1209 test 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}}
1218 test 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}}
1228 test 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 {}}
1238 test 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 {}}
1249 test 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 {}}
1260 test 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}}
1271 test 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}}
1282 test 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}}
1294 test 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 {}}
1306 test 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}}
1316 test 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}\
1328 0 {a b c}}
1329 test 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}\
1342 0 {a b c}}
1343 test 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
1366 test 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
1390 test 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
1412 test 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}}
1434 test 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}
1457 test 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
1480 test 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
1504 test 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
1526 test 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}}
1548 test 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}
1571 test 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)}}
1582 test 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)}}
1593 test 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)}}
1603 test 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)}}
1614 test 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
1626 test 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 *
1634 test 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
1649 test interp-21.1 {interp hidden} {
1650     interp hidden {}
1651 } ""
1652 test interp-21.2 {interp hidden} {
1653     interp hidden
1654 } ""
1655 test 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 {}}
1664 test 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 ""
1672 test 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
1680 test 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 {}}
1693 test 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 ""
1701 test 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
1709 test 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
1723 test 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}
1733 test 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}
1743 test 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}
1753 test 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}
1763 test 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}
1771 test 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}
1779 test 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}
1791 test 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}
1805 test 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
1821 test 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 {} {}}
1836 test 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 {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} $hidden_cmds {::tcl::mathfunc::max ::tcl::mathfunc::min bar clock} [lsort [concat $hidden_cmds bar]] {::tcl::mathfunc::max ::tcl::mathfunc::min clock} $hidden_cmds]
1851
1852 test 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}}
1864 test 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}}
1876 test 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}}
1892 test 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}}
1910 test 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}}
1928 test 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}}
1946 test 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}}
1959 test 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}}
1972 test 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}}
1991 test 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}}
2010 test 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}}
2028 test 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
2047 test 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
2059 test 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}
2073 test 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}
2086 test 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}
2103 test 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}
2116 test 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}
2132 test 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
2159 test 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"}
2178 test 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
2199 test 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}}}
2213 test 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}}}
2227 test 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}}}
2242 test 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}}}
2259 test 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"}}}
2275 test 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)}}
2312 test 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)}}
2347 test 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
2358 test 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 {}
2376 test 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
2402 test 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?"}}
2405 test interp-29.1.2 {interp recursionlimit argument checking} {
2406     list [catch {interp recursionlimit foo bar} msg] $msg
2407 } {1 {could not find interpreter "foo"}}
2408 test 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?"}}
2411 test 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"}}
2417 test 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}}
2423 test 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}}
2429 test 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}}
2435 test 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?"}}
2441 test 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"}}
2447 test 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}}
2453 test 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}}
2459 test 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}}
2465 test interp-29.2.1 {query recursion limit} {
2466     interp recursionlimit {}
2467 } 1000
2468 test 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
2474 test 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
2480 test 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}
2490 test 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}
2497 test 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}
2504 test 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}
2511 test 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}
2518 test 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}
2529 test 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}
2540 test 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}
2551 test 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}}
2571 test 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}}
2591 test 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 #
2615 test 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}
2636 test 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}
2657 test 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?)}}
2679 test 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}
2700 test 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?)}}
2721 test 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}
2742 test 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}
2763 test 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}
2784 test 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?)}}
2805 test 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}
2826 test 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?)}}
2848 test 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}
2869 test 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}
2891 test 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
2906 test 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
2919 test 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}
2928 test 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}
2937 test 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}
2946 test 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}
2955 test 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
2961 test 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
2967 test 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}
2974 test 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}
2981 test 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}
2988 test 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}
2995 test 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}
3002 test 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}}
3008 test 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}}
3022 test 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!
3063 test 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
3069 test 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
3087 test 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
3108 test 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
3118 test 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 }
3133 test 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 }
3148 test 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 }
3163 test 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 }
3179 test 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.
3208 test 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 }
3233 test 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 }
3258 test 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
3305 test 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}
3315 test 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}
3326 test 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}}
3342 test 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 }
3373 test 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 }
3400 test 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
3413 test interp-35.1 {interp limit syntax} -body {
3414     interp limit
3415 } -returnCodes error -result {wrong # args: should be "interp limit path limitType ?-option value ...?"}
3416 test interp-35.2 {interp limit syntax} -body {
3417     interp limit {}
3418 } -returnCodes error -result {wrong # args: should be "interp limit path limitType ?-option value ...?"}
3419 test interp-35.3 {interp limit syntax} -body {
3420     interp limit {} foo
3421 } -returnCodes error -result {bad limit type "foo": must be commands or time}
3422 test 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 {}}
3433 test 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
3439 test 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 {}
3445 test 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}
3451 test 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"}
3457 test 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}
3463 test 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"}
3469 test 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}
3475 test 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 {}}
3486 test 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
3492 test 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 {}
3498 test 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}
3504 test 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"}
3510 test 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}
3516 test 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"}
3522 test 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 } -returnCodes error -result {seconds must be at least 0}
3528 test 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"}
3534 test 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 } -returnCodes error -result {milliseconds must be at least 0}
3540 test 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
3548 test 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}
3551 test 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
3555 test interp-36.1 {interp bgerror syntax} -body {
3556     interp bgerror
3557 } -returnCodes error -result {wrong # args: should be "interp bgerror path ?cmdPrefix?"}
3558 test 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?"}
3561 test 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?"}
3568 test 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}
3575 test 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}
3582 test 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}
3589 test 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
3612 test 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
3625 test 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}
3635 test 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}
3645 test 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??"}
3650 test interp-38.4 {interp debug basic setup} -constraints {!singleTestInterp} -body {
3651     interp debug {}
3652 } -result {-frame 0}
3653 test interp-38.5 {interp debug basic setup} -constraints {!singleTestInterp} -body {
3654     interp debug {} -f
3655 } -result {0}
3656 test interp-38.6 {interp debug basic setup} -body {
3657     interp debug -frames
3658 } -returnCodes error -result {could not find interpreter "-frames"}
3659 test interp-38.7 {interp debug basic setup} -body {
3660     interp debug {} -frames
3661 } -returnCodes error -result {bad debug option "-frames": must be -frame}
3662 test 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 \f
3668 # cleanup
3669 unset -nocomplain hidden_cmds
3670 foreach i [interp children] {
3671     interp delete $i
3672 }
3673 ::tcltest::cleanupTests
3674 return
3675
3676 # Local Variables:
3677 # mode: tcl
3678 # fill-column: 78
3679 # End: