Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: downloads/tcl8.5.2/tests/interp.test @ 25

Last change on this file since 25 was 25, checked in by landauf, 16 years ago

added tcl to libs

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