OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tcl/] [tests/] [interp.test] - Blame information for rev 1767

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 578 markom 
# 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 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.1.1.1 2002-01-16 10:25:36 markom Exp $
14 
 
15 
if {[string compare test [info procs test]] == 1} then {source defs}
16 
 
17 
# The set of hidden commands is platform dependent:
18 
 
19 
if {"$tcl_platform(platform)" == "macintosh"} {
20 
    set hidden_cmds {beep cd echo exit fconfigure file glob load ls open pwd socket source}
21 
} else {
22 
    set hidden_cmds {cd exec exit fconfigure file glob load open pwd socket source}
23 
}
24 
 
25 
foreach i [interp slaves] {
26 
  interp delete $i
27 
}
28 
 
29 
proc equiv {x} {return $x}
30 
 
31 
# Part 0: Check out options for interp command
32 
test interp-1.1 {options for interp command} {
33 
    list [catch {interp} msg] $msg
34 
} {1 {wrong # args: should be "interp cmd ?arg ...?"}}
35 
test interp-1.2 {options for interp command} {
36 
    list [catch {interp frobox} msg] $msg
37 
} {1 {bad option "frobox": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, slaves, share, target, or transfer}}
38 
test interp-1.3 {options for interp command} {
39 
    interp delete
40 
} ""
41 
test interp-1.4 {options for interp command} {
42 
    list [catch {interp delete foo bar} msg] $msg
43 
} {1 {interpreter named "foo" not found}}
44 
test interp-1.5 {options for interp command} {
45 
    list [catch {interp exists foo bar} msg] $msg
46 
} {1 {wrong # args: should be "interp exists ?path?"}}
47 
#
48 
# test interp-0.6 was removed
49 
#
50 
test interp-1.6 {options for interp command} {
51 
    list [catch {interp slaves foo bar zop} msg] $msg
52 
} {1 {wrong # args: should be "interp slaves ?path?"}}
53 
test interp-1.7 {options for interp command} {
54 
    list [catch {interp hello} msg] $msg
55 
} {1 {bad option "hello": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, slaves, share, target, or transfer}}
56 
test interp-1.8 {options for interp command} {
57 
    list [catch {interp -froboz} msg] $msg
58 
} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, slaves, share, target, or transfer}}
59 
test interp-1.9 {options for interp command} {
60 
    list [catch {interp -froboz -safe} msg] $msg
61 
} {1 {bad option "-froboz": must be alias, aliases, create, delete, eval, exists, expose, hide, hidden, issafe, invokehidden, marktrusted, slaves, share, target, or transfer}}
62 
test interp-1.10 {options for interp command} {
63 
    list [catch {interp target} msg] $msg
64 
} {1 {wrong # args: should be "interp target path alias"}}
65 
 
66 
# Part 1: Basic interpreter creation tests:
67 
test interp-2.1 {basic interpreter creation} {
68 
    interp create a
69 
} a
70 
test interp-2.2 {basic interpreter creation} {
71 
    catch {interp create}
72 
} 0
73 
test interp-2.3 {basic interpreter creation} {
74 
    catch {interp create -safe}
75 
} 0
76 
test interp-2.4 {basic interpreter creation} {
77 
    list [catch {interp create a} msg] $msg
78 
} {1 {interpreter named "a" already exists, cannot create}}
79 
test interp-2.5 {basic interpreter creation} {
80 
    interp create b -safe
81 
} b
82 
test interp-2.6 {basic interpreter creation} {
83 
    interp create d -safe
84 
} d
85 
test interp-2.7 {basic interpreter creation} {
86 
    list [catch {interp create -froboz} msg] $msg
87 
} {1 {bad option "-froboz": should be -safe}}
88 
test interp-2.8 {basic interpreter creation} {
89 
    interp create -- -froboz
90 
} -froboz
91 
test interp-2.9 {basic interpreter creation} {
92 
    interp create -safe -- -froboz1
93 
} -froboz1
94 
test interp-2.10 {basic interpreter creation} {
95 
    interp create {a x1}
96 
    interp create {a x2}
97 
    interp create {a x3} -safe
98 
} {a x3}
99 
test interp-2.11 {anonymous interps vs existing procs} {
100 
    set x [interp create]
101 
    regexp "interp(\[0-9]+)" $x dummy thenum
102 
    interp delete $x
103 
    incr thenum
104 
    proc interp$thenum {} {}
105 
    set x [interp create]
106 
    regexp "interp(\[0-9]+)" $x dummy anothernum
107 
    expr $anothernum - $thenum
108 
} 1
109 
test interp-2.12 {anonymous interps vs existing procs} {
110 
    set x [interp create -safe]
111 
    regexp "interp(\[0-9]+)" $x dummy thenum
112 
    interp delete $x
113 
    incr thenum
114 
    proc interp$thenum {} {}
115 
    set x [interp create -safe]
116 
    regexp "interp(\[0-9]+)" $x dummy anothernum
117 
    expr $anothernum - $thenum
118 
} 1
119 
 
120 
foreach i [interp slaves] {
121 
    interp delete $i
122 
}
123 
 
124 
# Part 2: Testing "interp slaves" and "interp exists"
125 
test interp-3.1 {testing interp exists and interp slaves} {
126 
    interp slaves
127 
} ""
128 
test interp-3.2 {testing interp exists and interp slaves} {
129 
    interp create a
130 
    interp exists a
131 
} 1
132 
test interp-3.3 {testing interp exists and interp slaves} {
133 
    interp exists nonexistent
134 
} 0
135 
test interp-3.4 {testing interp exists and interp slaves} {
136 
    list [catch {interp slaves a b c} msg] $msg
137 
} {1 {wrong # args: should be "interp slaves ?path?"}}
138 
test interp-3.5 {testing interp exists and interp slaves} {
139 
    list [catch {interp exists a b c} msg] $msg
140 
} {1 {wrong # args: should be "interp exists ?path?"}}
141 
test interp-3.6 {testing interp exists and interp slaves} {
142 
    interp exists
143 
} 1
144 
test interp-3.7 {testing interp exists and interp slaves} {
145 
    interp slaves
146 
} a
147 
test interp-3.8 {testing interp exists and interp slaves} {
148 
    list [catch {interp slaves a b c} msg] $msg
149 
} {1 {wrong # args: should be "interp slaves ?path?"}}
150 
test interp-3.9 {testing interp exists and interp slaves} {
151 
    interp create {a a2} -safe
152 
    expr {[lsearch [interp slaves a] a2] >= 0}
153 
} 1
154 
test interp-3.10 {testing interp exists and interp slaves} {
155 
    interp exists {a a2}
156 
} 1
157 
 
158 
# Part 3: Testing "interp delete"
159 
test interp-3.11 {testing interp delete} {
160 
    interp delete
161 
} ""
162 
test interp-4.1 {testing interp delete} {
163 
    catch {interp create a}
164 
    interp delete a
165 
} ""
166 
test interp-4.2 {testing interp delete} {
167 
    list [catch {interp delete nonexistent} msg] $msg
168 
} {1 {interpreter named "nonexistent" not found}}
169 
test interp-4.3 {testing interp delete} {
170 
    list [catch {interp delete x y z} msg] $msg
171 
} {1 {interpreter named "x" not found}}
172 
test interp-4.4 {testing interp delete} {
173 
    interp delete
174 
} ""
175 
test interp-4.5 {testing interp delete} {
176 
    interp create a
177 
    interp create {a x1}
178 
    interp delete {a x1}
179 
    expr {[lsearch [interp slaves a] x1] >= 0}
180 
} 0
181 
test interp-4.6 {testing interp delete} {
182 
    interp create c1
183 
    interp create c2
184 
    interp create c3
185 
    interp delete c1 c2 c3
186 
} ""
187 
test interp-4.7 {testing interp delete} {
188 
    interp create c1
189 
    interp create c2
190 
    list [catch {interp delete c1 c2 c3} msg] $msg
191 
} {1 {interpreter named "c3" not found}}
192 
test interp-4.8 {testing interp delete} {
193 
    list [catch {interp delete {}} msg] $msg
194 
} {1 {interpreter named "" not found}}
195 
 
196 
foreach i [interp slaves] {
197 
    interp delete $i
198 
}
199 
 
200 
# Part 4: Consistency checking - all nondeleted interpreters should be
201 
# there:
202 
test interp-5.1 {testing consistency} {
203 
    interp slaves
204 
} ""
205 
test interp-5.2 {testing consistency} {
206 
    interp exists a
207 
} 0
208 
test interp-5.3 {testing consistency} {
209 
    interp exists nonexistent
210 
} 0
211 
 
212 
# Recreate interpreter "a"
213 
interp create a
214 
 
215 
# Part 5: Testing eval in interpreter object command and with interp command
216 
test interp-6.1 {testing eval} {
217 
    a eval expr 3 + 5
218 
} 8
219 
test interp-6.2 {testing eval} {
220 
    list [catch {a eval foo} msg] $msg
221 
} {1 {invalid command name "foo"}}
222 
test interp-6.3 {testing eval} {
223 
    a eval {proc foo {} {expr 3 + 5}}
224 
    a eval foo
225 
} 8
226 
test interp-6.4 {testing eval} {
227 
    interp eval a foo
228 
} 8
229 
 
230 
test interp-6.5 {testing eval} {
231 
    interp create {a x2}
232 
    interp eval {a x2} {proc frob {} {expr 4 * 9}}
233 
    interp eval {a x2} frob
234 
} 36
235 
test interp-6.6 {testing eval} {
236 
    list [catch {interp eval {a x2} foo} msg] $msg
237 
} {1 {invalid command name "foo"}}
238 
 
239 
# UTILITY PROCEDURE RUNNING IN MASTER INTERPRETER:
240 
proc in_master {args} {
241 
     return [list seen in master: $args]
242 
}
243 
 
244 
# Part 6: Testing basic alias creation
245 
test interp-7.1 {testing basic alias creation} {
246 
    a alias foo in_master
247 
} foo
248 
test interp-7.2 {testing basic alias creation} {
249 
    a alias bar in_master a1 a2 a3
250 
} bar
251 
# Test 6.3 has been deleted.
252 
test interp-7.3 {testing basic alias creation} {
253 
    a alias foo
254 
} in_master
255 
test interp-7.4 {testing basic alias creation} {
256 
    a alias bar
257 
} {in_master a1 a2 a3}
258 
test interp-7.5 {testing basic alias creation} {
259 
    a aliases
260 
} {foo bar}
261 
 
262 
# Part 7: testing basic alias invocation
263 
test interp-8.1 {testing basic alias invocation} {
264 
    catch {interp create a}
265 
    a alias foo in_master
266 
    a eval foo s1 s2 s3
267 
} {seen in master: {s1 s2 s3}}
268 
test interp-8.2 {testing basic alias invocation} {
269 
    catch {interp create a}
270 
    a alias bar in_master a1 a2 a3
271 
    a eval bar s1 s2 s3
272 
} {seen in master: {a1 a2 a3 s1 s2 s3}}
273 
 
274 
# Part 8: Testing aliases for non-existent targets
275 
test interp-9.1 {testing aliases for non-existent targets} {
276 
    catch {interp create a}
277 
    a alias zop nonexistent-command-in-master
278 
    list [catch {a eval zop} msg] $msg
279 
} {1 {invalid command name "nonexistent-command-in-master"}}
280 
test interp-9.2 {testing aliases for non-existent targets} {
281 
    catch {interp create a}
282 
    a alias zop nonexistent-command-in-master
283 
    proc nonexistent-command-in-master {} {return i_exist!}
284 
    a eval zop
285 
} i_exist!
286 
 
287 
if {[info command nonexistent-command-in-master] != ""} {
288 
    rename nonexistent-command-in-master {}
289 
}
290 
 
291 
# Part 9: Aliasing between interpreters
292 
test interp-10.1 {testing aliasing between interpreters} {
293 
    catch {interp delete a}
294 
    catch {interp delete b}
295 
    interp create a
296 
    interp create b
297 
    interp alias a a_alias b b_alias 1 2 3
298 
} a_alias
299 
test interp-10.2 {testing aliasing between interpreters} {
300 
    catch {interp delete a}
301 
    catch {interp delete b}
302 
    interp create a
303 
    interp create b
304 
    b eval {proc b_alias {args} {return [list got $args]}}
305 
    interp alias a a_alias b b_alias 1 2 3
306 
    a eval a_alias a b c
307 
} {got {1 2 3 a b c}}
308 
test interp-10.3 {testing aliasing between interpreters} {
309 
    catch {interp delete a}
310 
    catch {interp delete b}
311 
    interp create a
312 
    interp create b
313 
    interp alias a a_alias b b_alias 1 2 3
314 
    list [catch {a eval a_alias a b c} msg] $msg
315 
} {1 {invalid command name "b_alias"}}
316 
test interp-10.4 {testing aliasing between interpreters} {
317 
    catch {interp delete a}
318 
    interp create a
319 
    a alias a_alias puts
320 
    a aliases
321 
} a_alias
322 
test interp-10.5 {testing aliasing between interpreters} {
323 
    catch {interp delete a}
324 
    catch {interp delete b}
325 
    interp create a
326 
    interp create b
327 
    a alias a_alias puts
328 
    interp alias a a_del b b_del
329 
    interp delete b
330 
    a aliases
331 
} a_alias
332 
test interp-10.6 {testing aliasing between interpreters} {
333 
    catch {interp delete a}
334 
    catch {interp delete b}
335 
    interp create a
336 
    interp create b
337 
    interp alias a a_command b b_command a1 a2 a3
338 
    b alias b_command in_master b1 b2 b3
339 
    a eval a_command m1 m2 m3
340 
} {seen in master: {b1 b2 b3 a1 a2 a3 m1 m2 m3}}
341 
test interp-10.7 {testing aliases between interpreters} {
342 
    catch {interp delete a}
343 
    interp create a
344 
    interp alias "" foo a zoppo
345 
    a eval {proc zoppo {x} {list $x $x $x}}
346 
    set x [foo 33]
347 
    a eval {rename zoppo {}}
348 
    interp alias "" foo a {}
349 
    equiv $x
350 
} {33 33 33}
351 
 
352 
# Part 10: Testing "interp target"
353 
test interp-11.1 {testing interp target} {
354 
    list [catch {interp target} msg] $msg
355 
} {1 {wrong # args: should be "interp target path alias"}}
356 
test interp-11.2 {testing interp target} {
357 
    list [catch {interp target nosuchinterpreter foo} msg] $msg
358 
} {1 {could not find interpreter "nosuchinterpreter"}}
359 
test interp-11.3 {testing interp target} {
360 
    catch {interp delete a}
361 
    interp create a
362 
    a alias boo no_command
363 
    interp target a boo
364 
} ""
365 
test interp-11.4 {testing interp target} {
366 
    catch {interp delete x1}
367 
    interp create x1
368 
    x1 eval interp create x2
369 
    x1 eval x2 eval interp create x3
370 
    catch {interp delete y1}
371 
    interp create y1
372 
    y1 eval interp create y2
373 
    y1 eval y2 eval interp create y3
374 
    interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand
375 
    interp target {x1 x2 x3} xcommand
376 
} {y1 y2 y3}
377 
test interp-11.5 {testing interp target} {
378 
    catch {interp delete x1}
379 
    interp create x1
380 
    interp create {x1 x2}
381 
    interp create {x1 x2 x3}
382 
    catch {interp delete y1}
383 
    interp create y1
384 
    interp create {y1 y2}
385 
    interp create {y1 y2 y3}
386 
    interp alias {x1 x2 x3} xcommand {y1 y2 y3} ycommand
387 
    list [catch {x1 eval {interp target {x2 x3} xcommand}} msg] $msg
388 
} {1 {target interpreter for alias "xcommand" in path "x2 x3" is not my descendant}}
389 
test interp-11.6 {testing interp target} {
390 
    foreach a [interp aliases] {
391 
        rename $a {}
392 
    }
393 
    list [catch {interp target {} foo} msg] $msg
394 
} {1 {alias "foo" in path "" not found}}
395 
test interp-11.7 {testing interp target} {
396 
    catch {interp delete a}
397 
    interp create a
398 
    list [catch {interp target a foo} msg] $msg
399 
} {1 {alias "foo" in path "a" not found}}
400 
 
401 
# Part 11: testing "interp issafe"
402 
test interp-12.1 {testing interp issafe} {
403 
    interp issafe
404 
} 0
405 
test interp-12.2 {testing interp issafe} {
406 
    catch {interp delete a}
407 
    interp create a
408 
    interp issafe a
409 
} 0
410 
test interp-12.3 {testing interp issafe} {
411 
    catch {interp delete a}
412 
    interp create a
413 
    interp create {a x3} -safe
414 
    interp issafe {a x3}
415 
} 1
416 
test interp-12.4 {testing interp issafe} {
417 
    catch {interp delete a}
418 
    interp create a
419 
    interp create {a x3} -safe
420 
    interp create {a x3 foo}
421 
    interp issafe {a x3 foo}
422 
} 1
423 
 
424 
# Part 12: testing interpreter object command "issafe" sub-command
425 
test interp-13.1 {testing foo issafe} {
426 
    catch {interp delete a}
427 
    interp create a
428 
    a issafe
429 
} 0
430 
test interp-13.2 {testing foo issafe} {
431 
    catch {interp delete a}
432 
    interp create a
433 
    interp create {a x3} -safe
434 
    a eval x3 issafe
435 
} 1
436 
test interp-13.3 {testing foo issafe} {
437 
    catch {interp delete a}
438 
    interp create a
439 
    interp create {a x3} -safe
440 
    interp create {a x3 foo}
441 
    a eval x3 eval foo issafe
442 
} 1
443 
 
444 
# part 14: testing interp aliases
445 
test interp-14.1 {testing interp aliases} {
446 
    interp aliases
447 
} ""
448 
test interp-14.2 {testing interp aliases} {
449 
    catch {interp delete a}
450 
    interp create a
451 
    a alias a1 puts
452 
    a alias a2 puts
453 
    a alias a3 puts
454 
    lsort [interp aliases a]
455 
} {a1 a2 a3}
456 
test interp-14.3 {testing interp aliases} {
457 
    catch {interp delete a}
458 
    interp create a
459 
    interp create {a x3}
460 
    interp alias {a x3} froboz "" puts
461 
    interp aliases {a x3}
462 
} froboz
463 
 
464 
# part 15: testing file sharing
465 
test interp-15.1 {testing file sharing} {
466 
    catch {interp delete z}
467 
    interp create z
468 
    z eval close stdout
469 
    list [catch {z eval puts hello} msg] $msg
470 
} {1 {can not find channel named "stdout"}}
471 
catch {removeFile file-15.2}
472 
test interp-15.2 {testing file sharing} {
473 
    catch {interp delete z}
474 
    interp create z
475 
    set f [open file-15.2 w]
476 
    interp share "" $f z
477 
    z eval puts $f hello
478 
    z eval close $f
479 
    close $f
480 
} ""
481 
catch {removeFile file-15.2}
482 
test interp-15.3 {testing file sharing} {
483 
    catch {interp delete xsafe}
484 
    interp create xsafe -safe
485 
    list [catch {xsafe eval puts hello} msg] $msg
486 
} {1 {can not find channel named "stdout"}}
487 
catch {removeFile file-15.4}
488 
test interp-15.4 {testing file sharing} {
489 
    catch {interp delete xsafe}
490 
    interp create xsafe -safe
491 
    set f [open file-15.4 w]
492 
    interp share "" $f xsafe
493 
    xsafe eval puts $f hello
494 
    xsafe eval close $f
495 
    close $f
496 
} ""
497 
catch {removeFile file-15.4}
498 
test interp-15.5 {testing file sharing} {
499 
    catch {interp delete xsafe}
500 
    interp create xsafe -safe
501 
    interp share "" stdout xsafe
502 
    list [catch {xsafe eval gets stdout} msg] $msg
503 
} {1 {channel "stdout" wasn't opened for reading}}
504 
catch {removeFile file-15.6}
505 
test interp-15.6 {testing file sharing} {
506 
    catch {interp delete xsafe}
507 
    interp create xsafe -safe
508 
    set f [open file-15.6 w]
509 
    interp share "" $f xsafe
510 
    set x [list [catch [list xsafe eval gets $f] msg] $msg]
511 
    xsafe eval close $f
512 
    close $f
513 
    string compare [string tolower $x] \
514 
                [list 1 [format "channel \"%s\" wasn't opened for reading" $f]]
515 
} 0
516 
catch {removeFile file-15.6}
517 
catch {removeFile file-15.7}
518 
test interp-15.7 {testing file transferring} {
519 
    catch {interp delete xsafe}
520 
    interp create xsafe -safe
521 
    set f [open file-15.7 w]
522 
    interp transfer "" $f xsafe
523 
    xsafe eval puts $f hello
524 
    xsafe eval close $f
525 
} ""
526 
catch {removeFile file-15.7}
527 
catch {removeFile file-15.8}
528 
test interp-15.8 {testing file transferring} {
529 
    catch {interp delete xsafe}
530 
    interp create xsafe -safe
531 
    set f [open file-15.8 w]
532 
    interp transfer "" $f xsafe
533 
    xsafe eval close $f
534 
    set x [list [catch {close $f} msg] $msg]
535 
    string compare [string tolower $x] \
536 
                [list 1 [format "can not find channel named \"%s\"" $f]]
537 
} 0
538 
catch {removeFile file-15.8}
539 
 
540 
#
541 
# Torture tests for interpreter deletion order
542 
#
543 
proc kill {} {interp delete xxx}
544 
 
545 
test interp-15.9 {testing deletion order} {
546 
    catch {interp delete xxx}
547 
    interp create xxx
548 
    xxx alias kill kill
549 
    list [catch {xxx eval kill} msg] $msg
550 
} {0 {}}
551 
test interp-16.1 {testing deletion order} {
552 
    catch {interp delete xxx}
553 
    interp create xxx
554 
    interp create {xxx yyy}
555 
    interp alias {xxx yyy} kill "" kill
556 
    list [catch {interp eval {xxx yyy} kill} msg] $msg
557 
} {0 {}}
558 
test interp-16.2 {testing deletion order} {
559 
    catch {interp delete xxx}
560 
    interp create xxx
561 
    interp create {xxx yyy}
562 
    interp alias {xxx yyy} kill "" kill
563 
    list [catch {xxx eval yyy eval kill} msg] $msg
564 
} {0 {}}
565 
test interp-16.3 {testing deletion order} {
566 
    catch {interp delete xxx}
567 
    interp create xxx
568 
    interp create ddd
569 
    xxx alias kill kill
570 
    interp alias ddd kill xxx kill
571 
    set x [ddd eval kill]
572 
    interp delete ddd
573 
    set x
574 
} ""
575 
test interp-16.4 {testing deletion order} {
576 
    catch {interp delete xxx}
577 
    interp create xxx
578 
    interp create {xxx yyy}
579 
    interp alias {xxx yyy} kill "" kill
580 
    interp create ddd
581 
    interp alias ddd kill {xxx yyy} kill
582 
    set x [ddd eval kill]
583 
    interp delete ddd
584 
    set x
585 
} ""
586 
test interp-16.5 {testing deletion order, bgerror} {
587 
    catch {interp delete xxx}
588 
    interp create xxx
589 
    xxx eval {proc bgerror {args} {exit}}
590 
    xxx alias exit kill xxx
591 
    proc kill {i} {interp delete $i}
592 
    xxx eval after 100 expr a + b
593 
    after 200
594 
    update
595 
    interp exists xxx
596 
} 0
597 
 
598 
#
599 
# Alias loop prevention testing.
600 
#
601 
 
602 
test interp-17.1 {alias loop prevention} {
603 
    list [catch {interp alias {} a {} a} msg] $msg
604 
} {1 {cannot define or rename alias "a": would create a loop}}
605 
test interp-17.2 {alias loop prevention} {
606 
    catch {interp delete x}
607 
    interp create x
608 
    x alias a loop
609 
    list [catch {interp alias {} loop x a} msg] $msg
610 
} {1 {cannot define or rename alias "loop": would create a loop}}
611 
test interp-17.3 {alias loop prevention} {
612 
    catch {interp delete x}
613 
    interp create x
614 
    interp alias x a x b
615 
    list [catch {interp alias x b x a} msg] $msg
616 
} {1 {cannot define or rename alias "b": would create a loop}}
617 
test interp-17.4 {alias loop prevention} {
618 
    catch {interp delete x}
619 
    interp create x
620 
    interp alias x b x a
621 
    list [catch {x eval rename b a} msg] $msg
622 
} {1 {cannot define or rename alias "b": would create a loop}}
623 
test interp-17.5 {alias loop prevention} {
624 
    catch {interp delete x}
625 
    interp create x
626 
    x alias z l1
627 
    interp alias {} l2 x z
628 
    list [catch {rename l2 l1} msg] $msg
629 
} {1 {cannot define or rename alias "l2": would create a loop}}
630 
 
631 
#
632 
# Test robustness of Tcl_DeleteInterp when applied to a slave interpreter.
633 
# If there are bugs in the implementation these tests are likely to expose
634 
# the bugs as a core dump.
635 
#
636 
 
637 
if {[info commands testinterpdelete] != ""} {
638 
    test interp-18.1 {testing Tcl_DeleteInterp vs slaves} {
639 
        list [catch {testinterpdelete} msg] $msg
640 
    } {1 {wrong # args: should be "testinterpdelete path"}}
641 
    test interp-18.2 {testing Tcl_DeleteInterp vs slaves} {
642 
        catch {interp delete a}
643 
        interp create a
644 
        testinterpdelete a
645 
    } ""
646 
    test interp-18.3 {testing Tcl_DeleteInterp vs slaves} {
647 
        catch {interp delete a}
648 
        interp create a
649 
        interp create {a b}
650 
        testinterpdelete {a b}
651 
    } ""
652 
    test interp-18.4 {testing Tcl_DeleteInterp vs slaves} {
653 
        catch {interp delete a}
654 
        interp create a
655 
        interp create {a b}
656 
        testinterpdelete a
657 
    } ""
658 
    test interp-18.5 {testing Tcl_DeleteInterp vs slaves} {
659 
        catch {interp delete a}
660 
        interp create a
661 
        interp create {a b}
662 
        interp alias {a b} dodel {} dodel
663 
        proc dodel {x} {testinterpdelete $x}
664 
        list [catch {interp eval {a b} {dodel {a b}}} msg] $msg
665 
    } {0 {}}
666 
    test interp-18.6 {testing Tcl_DeleteInterp vs slaves} {
667 
        catch {interp delete a}
668 
        interp create a
669 
        interp create {a b}
670 
        interp alias {a b} dodel {} dodel
671 
        proc dodel {x} {testinterpdelete $x}
672 
        list [catch {interp eval {a b} {dodel a}} msg] $msg
673 
    } {0 {}}
674 
    test interp-18.7 {eval in deleted interp} {
675 
        catch {interp delete a}
676 
        interp create a
677 
        a eval {
678 
            proc dodel {} {
679 
                delme
680 
                dosomething else
681 
            }
682 
            proc dosomething args {
683 
                puts "I should not have been called!!"
684 
            }
685 
        }
686 
        a alias delme dela
687 
        proc dela {} {interp delete a}
688 
        list [catch {a eval dodel} msg] $msg
689 
    } {1 {attempt to call eval in deleted interpreter}}
690 
    test interp-18.8 {eval in deleted interp} {
691 
        catch {interp delete a}
692 
        interp create a
693 
        a eval {
694 
            interp create b
695 
            b eval {
696 
                proc dodel {} {
697 
                    dela
698 
                }
699 
            }
700 
            proc foo {} {
701 
                b eval dela
702 
                dosomething else
703 
            }
704 
            proc dosomething args {
705 
                puts "I should not have been called!!"
706 
            }
707 
        }
708 
        interp alias {a b} dela {} dela
709 
        proc dela {} {interp delete a}
710 
        list [catch {a eval foo} msg] $msg
711 
    } {1 {attempt to call eval in deleted interpreter}}
712 
}
713 
 
714 
# Test alias deletion
715 
 
716 
test interp-19.1 {alias deletion} {
717 
    catch {interp delete a}
718 
    interp create a
719 
    interp alias a foo a bar
720 
    set s [interp alias a foo {}]
721 
    interp delete a
722 
    set s
723 
} {}
724 
test interp-19.2 {alias deletion} {
725 
    catch {interp delete a}
726 
    interp create a
727 
    catch {interp alias a foo {}} msg
728 
    interp delete a
729 
    set msg
730 
} {alias "foo" not found}
731 
test interp-19.3 {alias deletion} {
732 
    catch {interp delete a}
733 
    interp create a
734 
    interp alias a foo a bar
735 
    interp eval a {rename foo zop}
736 
    interp alias a foo a zop
737 
    catch {interp eval a foo} msg
738 
    interp delete a
739 
    set msg
740 
} {invalid command name "zop"}
741 
test interp-19.4 {alias deletion} {
742 
    catch {interp delete a}
743 
    interp create a
744 
    interp alias a foo a bar
745 
    interp eval a {rename foo zop}
746 
    catch {interp eval a foo} msg
747 
    interp delete a
748 
    set msg
749 
} {invalid command name "foo"}
750 
test interp-19.5 {alias deletion} {
751 
    catch {interp delete a}
752 
    interp create a
753 
    interp eval a {proc bar {} {return 1}}
754 
    interp alias a foo a bar
755 
    interp eval a {rename foo zop}
756 
    catch {interp eval a zop} msg
757 
    interp delete a
758 
    set msg
759 
} 1
760 
test interp-19.6 {alias deletion} {
761 
    catch {interp delete a}
762 
    interp create a
763 
    interp alias a foo a bar
764 
    interp eval a {rename foo zop}
765 
    interp alias a foo a zop
766 
    set s [interp aliases a]
767 
    interp delete a
768 
    set s
769 
} foo
770 
test interp-19.7 {alias deletion, renaming} {
771 
    catch {interp delete a}
772 
    interp create a
773 
    interp alias a foo a bar
774 
    interp eval a rename foo blotz
775 
    interp alias a foo {}
776 
    set s [interp aliases a]
777 
    interp delete a
778 
    set s
779 
} {}
780 
test interp-19.8 {alias deletion, renaming} {
781 
    catch {interp delete a}
782 
    interp create a
783 
    interp alias a foo a bar
784 
    interp eval a rename foo blotz
785 
    set l ""
786 
    lappend l [interp aliases a]
787 
    interp alias a foo {}
788 
    lappend l [interp aliases a]
789 
    interp delete a
790 
    set l
791 
} {foo {}}
792 
test interp-19.9 {alias deletion, renaming} {
793 
    catch {interp delete a}
794 
    interp create a
795 
    interp alias a foo a bar
796 
    interp eval a rename foo blotz
797 
    interp eval a {proc foo {} {expr 34 * 34}}
798 
    interp alias a foo {}
799 
    set l [interp eval a foo]
800 
    interp delete a
801 
    set l
802 
} 1156
803 
 
804 
test interp-20.1 {interp hide, interp expose and interp invokehidden} {
805 
    catch {interp delete a}
806 
    interp create a
807 
    a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
808 
    a eval {proc foo {} {}}
809 
    a hide foo
810 
    catch {a eval foo something} msg
811 
    interp delete a
812 
    set msg
813 
} {invalid command name "foo"}
814 
test interp-20.2 {interp hide, interp expose and interp invokehidden} {
815 
    catch {interp delete a}
816 
    interp create a
817 
    a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
818 
    a hide list
819 
    set l ""
820 
    lappend l [catch {a eval {list 1 2 3}} msg]
821 
    lappend l $msg
822 
    a expose list
823 
    lappend l [catch {a eval {list 1 2 3}} msg]
824 
    lappend l $msg
825 
    interp delete a
826 
    set l
827 
} {1 {invalid command name "list"} 0 {1 2 3}}
828 
test interp-20.3 {interp hide, interp expose and interp invokehidden} {
829 
    catch {interp delete a}
830 
    interp create a
831 
    a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
832 
    a hide list
833 
    set l ""
834 
    lappend l [catch {a eval {list 1 2 3}} msg]
835 
    lappend l $msg
836 
    lappend l [catch {a invokehidden list 1 2 3} msg]
837 
    lappend l $msg
838 
    a expose list
839 
    lappend l [catch {a eval {list 1 2 3}} msg]
840 
    lappend l $msg
841 
    interp delete a
842 
    set l
843 
} {1 {invalid command name "list"} 0 {1 2 3} 0 {1 2 3}}
844 
test interp-20.4 {interp hide, interp expose and interp invokehidden -- passing {}} {
845 
    catch {interp delete a}
846 
    interp create a
847 
    a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
848 
    a hide list
849 
    set l ""
850 
    lappend l [catch {a eval {list 1 2 3}} msg]
851 
    lappend l $msg
852 
    lappend l [catch {a invokehidden list {"" 1 2 3}} msg]
853 
    lappend l $msg
854 
    a expose list
855 
    lappend l [catch {a eval {list 1 2 3}} msg]
856 
    lappend l $msg
857 
    interp delete a
858 
    set l
859 
} {1 {invalid command name "list"} 0 {{"" 1 2 3}} 0 {1 2 3}}
860 
test interp-20.5 {interp hide, interp expose and interp invokehidden -- passing {}} {
861 
    catch {interp delete a}
862 
    interp create a
863 
    a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
864 
    a hide list
865 
    set l ""
866 
    lappend l [catch {a eval {list 1 2 3}} msg]
867 
    lappend l $msg
868 
    lappend l [catch {a invokehidden list {{} 1 2 3}} msg]
869 
    lappend l $msg
870 
    a expose list
871 
    lappend l [catch {a eval {list 1 2 3}} msg]
872 
    lappend l $msg
873 
    interp delete a
874 
    set l
875 
} {1 {invalid command name "list"} 0 {{{} 1 2 3}} 0 {1 2 3}}
876 
test interp-20.6 {interp invokehidden -- eval args} {
877 
    catch {interp delete a}
878 
    interp create a
879 
    a hide list
880 
    set l ""
881 
    set z 45
882 
    lappend l [catch {a invokehidden list $z 1 2 3} msg]
883 
    lappend l $msg
884 
    a expose list
885 
    lappend l [catch {a eval list $z 1 2 3} msg]
886 
    lappend l $msg
887 
    interp delete a
888 
    set l
889 
} {0 {45 1 2 3} 0 {45 1 2 3}}
890 
test interp-20.7 {interp invokehidden vs variable eval} {
891 
    catch {interp delete a}
892 
    interp create a
893 
    a hide list
894 
    set z 45
895 
    set l ""
896 
    lappend l [catch {a invokehidden list {$z a b c}} msg]
897 
    lappend l $msg
898 
    interp delete a
899 
    set l
900 
} {0 {{$z a b c}}}
901 
test interp-20.8 {interp invokehidden vs variable eval} {
902 
    catch {interp delete a}
903 
    interp create a
904 
    a hide list
905 
    a eval set z 89
906 
    set z 45
907 
    set l ""
908 
    lappend l [catch {a invokehidden list {$z a b c}} msg]
909 
    lappend l $msg
910 
    interp delete a
911 
    set l
912 
} {0 {{$z a b c}}}
913 
test interp-20.9 {interp invokehidden vs variable eval} {
914 
    catch {interp delete a}
915 
    interp create a
916 
    a hide list
917 
    a eval set z 89
918 
    set z 45
919 
    set l ""
920 
    lappend l [catch {a invokehidden list $z {$z a b c}} msg]
921 
    lappend l $msg
922 
    interp delete a
923 
    set l
924 
} {0 {45 {$z a b c}}}
925 
test interp-20.10 {interp hide, interp expose and interp invokehidden} {
926 
    catch {interp delete a}
927 
    interp create a
928 
    a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
929 
    a eval {proc foo {} {}}
930 
    interp hide a foo
931 
    catch {interp eval a foo something} msg
932 
    interp delete a
933 
    set msg
934 
} {invalid command name "foo"}
935 
test interp-20.11 {interp hide, interp expose and interp invokehidden} {
936 
    catch {interp delete a}
937 
    interp create a
938 
    a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
939 
    interp hide a list
940 
    set l ""
941 
    lappend l [catch {interp eval a {list 1 2 3}} msg]
942 
    lappend l $msg
943 
    interp expose a list
944 
    lappend l [catch {interp eval a {list 1 2 3}} msg]
945 
    lappend l $msg
946 
    interp delete a
947 
    set l
948 
} {1 {invalid command name "list"} 0 {1 2 3}}
949 
test interp-20.12 {interp hide, interp expose and interp invokehidden} {
950 
    catch {interp delete a}
951 
    interp create a
952 
    a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
953 
    interp hide a list
954 
    set l ""
955 
    lappend l [catch {interp eval a {list 1 2 3}} msg]
956 
    lappend l $msg
957 
    lappend l [catch {interp invokehidden a list 1 2 3} msg]
958 
    lappend l $msg
959 
    interp expose a list
960 
    lappend l [catch {interp eval a {list 1 2 3}} msg]
961 
    lappend l $msg
962 
    interp delete a
963 
    set l
964 
} {1 {invalid command name "list"} 0 {1 2 3} 0 {1 2 3}}
965 
test interp-20.13 {interp hide, interp expose, interp invokehidden -- passing {}} {
966 
    catch {interp delete a}
967 
    interp create a
968 
    a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
969 
    interp hide a list
970 
    set l ""
971 
    lappend l [catch {interp eval a {list 1 2 3}} msg]
972 
    lappend l $msg
973 
    lappend l [catch {interp invokehidden a list {"" 1 2 3}} msg]
974 
    lappend l $msg
975 
    interp expose a list
976 
    lappend l [catch {interp eval a {list 1 2 3}} msg]
977 
    lappend l $msg
978 
    interp delete a
979 
    set l
980 
} {1 {invalid command name "list"} 0 {{"" 1 2 3}} 0 {1 2 3}}
981 
test interp-20.14 {interp hide, interp expose, interp invokehidden -- passing {}} {
982 
    catch {interp delete a}
983 
    interp create a
984 
    a eval {proc unknown {x args} {error "invalid command name \"$x\""}}
985 
    interp hide a list
986 
    set l ""
987 
    lappend l [catch {interp eval a {list 1 2 3}} msg]
988 
    lappend l $msg
989 
    lappend l [catch {interp invokehidden a list {{} 1 2 3}} msg]
990 
    lappend l $msg
991 
    interp expose a list
992 
    lappend l [catch {a eval {list 1 2 3}} msg]
993 
    lappend l $msg
994 
    interp delete a
995 
    set l
996 
} {1 {invalid command name "list"} 0 {{{} 1 2 3}} 0 {1 2 3}}
997 
test interp-20.15 {interp invokehidden -- eval args} {
998 
    catch {interp delete a}
999 
    interp create a
1000 
    interp hide a list
1001 
    set l ""
1002 
    set z 45
1003 
    lappend l [catch {interp invokehidden a list $z 1 2 3} msg]
1004 
    lappend l $msg
1005 
    a expose list
1006 
    lappend l [catch {interp eval a list $z 1 2 3} msg]
1007 
    lappend l $msg
1008 
    interp delete a
1009 
    set l
1010 
} {0 {45 1 2 3} 0 {45 1 2 3}}
1011 
test interp-20.16 {interp invokehidden vs variable eval} {
1012 
    catch {interp delete a}
1013 
    interp create a
1014 
    interp hide a list
1015 
    set z 45
1016 
    set l ""
1017 
    lappend l [catch {interp invokehidden a list {$z a b c}} msg]
1018 
    lappend l $msg
1019 
    interp delete a
1020 
    set l
1021 
} {0 {{$z a b c}}}
1022 
test interp-20.17 {interp invokehidden vs variable eval} {
1023 
    catch {interp delete a}
1024 
    interp create a
1025 
    interp hide a list
1026 
    a eval set z 89
1027 
    set z 45
1028 
    set l ""
1029 
    lappend l [catch {interp invokehidden a list {$z a b c}} msg]
1030 
    lappend l $msg
1031 
    interp delete a
1032 
    set l
1033 
} {0 {{$z a b c}}}
1034 
test interp-20.18 {interp invokehidden vs variable eval} {
1035 
    catch {interp delete a}
1036 
    interp create a
1037 
    interp hide a list
1038 
    a eval set z 89
1039 
    set z 45
1040 
    set l ""
1041 
    lappend l [catch {interp invokehidden a list $z {$z a b c}} msg]
1042 
    lappend l $msg
1043 
    interp delete a
1044 
    set l
1045 
} {0 {45 {$z a b c}}}
1046 
test interp-20.19 {interp invokehidden vs nested commands} {
1047 
    catch {interp delete a}
1048 
    interp create a
1049 
    a hide list
1050 
    set l [a invokehidden list {[list x y z] f g h} z]
1051 
    interp delete a
1052 
    set l
1053 
} {{[list x y z] f g h} z}
1054 
test interp-20.20 {interp invokehidden vs nested commands} {
1055 
    catch {interp delete a}
1056 
    interp create a
1057 
    a hide list
1058 
    set l [interp invokehidden a list {[list x y z] f g h} z]
1059 
    interp delete a
1060 
    set l
1061 
} {{[list x y z] f g h} z}
1062 
test interp-20.21 {interp hide vs safety} {
1063 
    catch {interp delete a}
1064 
    interp create a -safe
1065 
    set l ""
1066 
    lappend l [catch {a hide list} msg]
1067 
    lappend l $msg
1068 
    interp delete a
1069 
    set l
1070 
} {0 {}}
1071 
test interp-20.22 {interp hide vs safety} {
1072 
    catch {interp delete a}
1073 
    interp create a -safe
1074 
    set l ""
1075 
    lappend l [catch {interp hide a list} msg]
1076 
    lappend l $msg
1077 
    interp delete a
1078 
    set l
1079 
} {0 {}}
1080 
test interp-20.23 {interp hide vs safety} {
1081 
    catch {interp delete a}
1082 
    interp create a -safe
1083 
    set l ""
1084 
    lappend l [catch {a eval {interp hide {} list}} msg]
1085 
    lappend l $msg
1086 
    interp delete a
1087 
    set l
1088 
} {1 {permission denied: safe interpreter cannot hide commands}}
1089 
test interp-20.24 {interp hide vs safety} {
1090 
    catch {interp delete a}
1091 
    interp create a -safe
1092 
    interp create {a b}
1093 
    set l ""
1094 
    lappend l [catch {a eval {interp hide b list}} msg]
1095 
    lappend l $msg
1096 
    interp delete a
1097 
    set l
1098 
} {1 {permission denied: safe interpreter cannot hide commands}}
1099 
test interp-20.25 {interp hide vs safety} {
1100 
    catch {interp delete a}
1101 
    interp create a -safe
1102 
    interp create {a b}
1103 
    set l ""
1104 
    lappend l [catch {interp hide {a b} list} msg]
1105 
    lappend l $msg
1106 
    interp delete a
1107 
    set l
1108 
} {0 {}}
1109 
test interp-20.26 {interp expoose vs safety} {
1110 
    catch {interp delete a}
1111 
    interp create a -safe
1112 
    set l ""
1113 
    lappend l [catch {a hide list} msg]
1114 
    lappend l $msg
1115 
    lappend l [catch {a expose list} msg]
1116 
    lappend l $msg
1117 
    interp delete a
1118 
    set l
1119 
} {0 {} 0 {}}
1120 
test interp-20.27 {interp expose vs safety} {
1121 
    catch {interp delete a}
1122 
    interp create a -safe
1123 
    set l ""
1124 
    lappend l [catch {interp hide a list} msg]
1125 
    lappend l $msg
1126 
    lappend l [catch {interp expose a list} msg]
1127 
    lappend l $msg
1128 
    interp delete a
1129 
    set l
1130 
} {0 {} 0 {}}
1131 
test interp-20.28 {interp expose vs safety} {
1132 
    catch {interp delete a}
1133 
    interp create a -safe
1134 
    set l ""
1135 
    lappend l [catch {a hide list} msg]
1136 
    lappend l $msg
1137 
    lappend l [catch {a eval {interp expose {} list}} msg]
1138 
    lappend l $msg
1139 
    interp delete a
1140 
    set l
1141 
} {0 {} 1 {permission denied: safe interpreter cannot expose commands}}
1142 
test interp-20.29 {interp expose vs safety} {
1143 
    catch {interp delete a}
1144 
    interp create a -safe
1145 
    set l ""
1146 
    lappend l [catch {interp hide a list} msg]
1147 
    lappend l $msg
1148 
    lappend l [catch {a eval {interp expose {} list}} msg]
1149 
    lappend l $msg
1150 
    interp delete a
1151 
    set l
1152 
} {0 {} 1 {permission denied: safe interpreter cannot expose commands}}
1153 
test interp-20.30 {interp expose vs safety} {
1154 
    catch {interp delete a}
1155 
    interp create a -safe
1156 
    interp create {a b}
1157 
    set l ""
1158 
    lappend l [catch {interp hide {a b} list} msg]
1159 
    lappend l $msg
1160 
    lappend l [catch {a eval {interp expose b list}} msg]
1161 
    lappend l $msg
1162 
    interp delete a
1163 
    set l
1164 
} {0 {} 1 {permission denied: safe interpreter cannot expose commands}}
1165 
test interp-20.31 {interp expose vs safety} {
1166 
    catch {interp delete a}
1167 
    interp create a -safe
1168 
    interp create {a b}
1169 
    set l ""
1170 
    lappend l [catch {interp hide {a b} list} msg]
1171 
    lappend l $msg
1172 
    lappend l [catch {interp expose {a b} list} msg]
1173 
    lappend l $msg
1174 
    interp delete a
1175 
    set l
1176 
} {0 {} 0 {}}
1177 
test interp-20.32 {interp invokehidden vs safety} {
1178 
    catch {interp delete a}
1179 
    interp create a -safe
1180 
    interp hide a list
1181 
    set l ""
1182 
    lappend l [catch {a eval {interp invokehidden {} list a b c}} msg]
1183 
    lappend l $msg
1184 
    interp delete a
1185 
    set l
1186 
} {1 {not allowed to invoke hidden commands from safe interpreter}}
1187 
test interp-20.33 {interp invokehidden vs safety} {
1188 
    catch {interp delete a}
1189 
    interp create a -safe
1190 
    interp hide a list
1191 
    set l ""
1192 
    lappend l [catch {a eval {interp invokehidden {} list a b c}} msg]
1193 
    lappend l $msg
1194 
    lappend l [catch {a invokehidden list a b c} msg]
1195 
    lappend l $msg
1196 
    interp delete a
1197 
    set l
1198 
} {1 {not allowed to invoke hidden commands from safe interpreter}\
1199 
 
1200 
test interp-20.34 {interp invokehidden vs safety} {
1201 
    catch {interp delete a}
1202 
    interp create a -safe
1203 
    interp create {a b}
1204 
    interp hide {a b} list
1205 
    set l ""
1206 
    lappend l [catch {a eval {interp invokehidden b list a b c}} msg]
1207 
    lappend l $msg
1208 
    lappend l [catch {interp invokehidden {a b} list a b c} msg]
1209 
    lappend l $msg
1210 
    interp delete a
1211 
    set l
1212 
} {1 {not allowed to invoke hidden commands from safe interpreter}\
1213 
 
1214 
test interp-20.35 {invokehidden at local level} {
1215 
    catch {interp delete a}
1216 
    interp create a
1217 
    a eval {
1218 
        proc p1 {} {
1219 
            set z 90
1220 
            a1
1221 
            set z
1222 
        }
1223 
        proc h1 {} {
1224 
            upvar z z
1225 
            set z 91
1226 
        }
1227 
    }
1228 
    a hide h1
1229 
    a alias a1 a1
1230 
    proc a1 {} {
1231 
        interp invokehidden a h1
1232 
    }
1233 
    set r [interp eval a p1]
1234 
    interp delete a
1235 
    set r
1236 
} 91
1237 
test interp-20.36 {invokehidden at local level} {
1238 
    catch {interp delete a}
1239 
    interp create a
1240 
    a eval {
1241 
        set z 90
1242 
        proc p1 {} {
1243 
            global z
1244 
            a1
1245 
            set z
1246 
        }
1247 
        proc h1 {} {
1248 
            upvar z z
1249 
            set z 91
1250 
        }
1251 
    }
1252 
    a hide h1
1253 
    a alias a1 a1
1254 
    proc a1 {} {
1255 
        interp invokehidden a h1
1256 
    }
1257 
    set r [interp eval a p1]
1258 
    interp delete a
1259 
    set r
1260 
} 91
1261 
test interp-20.37 {invokehidden at local level} {
1262 
    catch {interp delete a}
1263 
    interp create a
1264 
    a eval {
1265 
        proc p1 {} {
1266 
            a1
1267 
            set z
1268 
        }
1269 
        proc h1 {} {
1270 
            upvar z z
1271 
            set z 91
1272 
        }
1273 
    }
1274 
    a hide h1
1275 
    a alias a1 a1
1276 
    proc a1 {} {
1277 
        interp invokehidden a h1
1278 
    }
1279 
    set r [interp eval a p1]
1280 
    interp delete a
1281 
    set r
1282 
} 91
1283 
test interp-20.38 {invokehidden at global level} {
1284 
    catch {interp delete a}
1285 
    interp create a
1286 
    a eval {
1287 
        proc p1 {} {
1288 
            a1
1289 
            set z
1290 
        }
1291 
        proc h1 {} {
1292 
            upvar z z
1293 
            set z 91
1294 
        }
1295 
    }
1296 
    a hide h1
1297 
    a alias a1 a1
1298 
    proc a1 {} {
1299 
        interp invokehidden a -global h1
1300 
    }
1301 
    set r [catch {interp eval a p1} msg]
1302 
    interp delete a
1303 
    list $r $msg
1304 
} {1 {can't read "z": no such variable}}
1305 
test interp-20.39 {invokehidden at global level} {
1306 
    catch {interp delete a}
1307 
    interp create a
1308 
    a eval {
1309 
        proc p1 {} {
1310 
            global z
1311 
            a1
1312 
            set z
1313 
        }
1314 
        proc h1 {} {
1315 
            upvar z z
1316 
            set z 91
1317 
        }
1318 
    }
1319 
    a hide h1
1320 
    a alias a1 a1
1321 
    proc a1 {} {
1322 
        interp invokehidden a -global h1
1323 
    }
1324 
    set r [catch {interp eval a p1} msg]
1325 
    interp delete a
1326 
    list $r $msg
1327 
} {0 91}
1328 
test interp-20.40 {safe, invokehidden at local level} {
1329 
    catch {interp delete a}
1330 
    interp create a -safe
1331 
    a eval {
1332 
        proc p1 {} {
1333 
            set z 90
1334 
            a1
1335 
            set z
1336 
        }
1337 
        proc h1 {} {
1338 
            upvar z z
1339 
            set z 91
1340 
        }
1341 
    }
1342 
    a hide h1
1343 
    a alias a1 a1
1344 
    proc a1 {} {
1345 
        interp invokehidden a h1
1346 
    }
1347 
    set r [interp eval a p1]
1348 
    interp delete a
1349 
    set r
1350 
} 91
1351 
test interp-20.41 {safe, invokehidden at local level} {
1352 
    catch {interp delete a}
1353 
    interp create a -safe
1354 
    a eval {
1355 
        set z 90
1356 
        proc p1 {} {
1357 
            global z
1358 
            a1
1359 
            set z
1360 
        }
1361 
        proc h1 {} {
1362 
            upvar z z
1363 
            set z 91
1364 
        }
1365 
    }
1366 
    a hide h1
1367 
    a alias a1 a1
1368 
    proc a1 {} {
1369 
        interp invokehidden a h1
1370 
    }
1371 
    set r [interp eval a p1]
1372 
    interp delete a
1373 
    set r
1374 
} 91
1375 
test interp-20.42 {safe, invokehidden at local level} {
1376 
    catch {interp delete a}
1377 
    interp create a -safe
1378 
    a eval {
1379 
        proc p1 {} {
1380 
            a1
1381 
            set z
1382 
        }
1383 
        proc h1 {} {
1384 
            upvar z z
1385 
            set z 91
1386 
        }
1387 
    }
1388 
    a hide h1
1389 
    a alias a1 a1
1390 
    proc a1 {} {
1391 
        interp invokehidden a h1
1392 
    }
1393 
    set r [interp eval a p1]
1394 
    interp delete a
1395 
    set r
1396 
} 91
1397 
test interp-20.43 {invokehidden at global level} {
1398 
    catch {interp delete a}
1399 
    interp create a
1400 
    a eval {
1401 
        proc p1 {} {
1402 
            a1
1403 
            set z
1404 
        }
1405 
        proc h1 {} {
1406 
            upvar z z
1407 
            set z 91
1408 
        }
1409 
    }
1410 
    a hide h1
1411 
    a alias a1 a1
1412 
    proc a1 {} {
1413 
        interp invokehidden a -global h1
1414 
    }
1415 
    set r [catch {interp eval a p1} msg]
1416 
    interp delete a
1417 
    list $r $msg
1418 
} {1 {can't read "z": no such variable}}
1419 
test interp-20.44 {invokehidden at global level} {
1420 
    catch {interp delete a}
1421 
    interp create a
1422 
    a eval {
1423 
        proc p1 {} {
1424 
            global z
1425 
            a1
1426 
            set z
1427 
        }
1428 
        proc h1 {} {
1429 
            upvar z z
1430 
            set z 91
1431 
        }
1432 
    }
1433 
    a hide h1
1434 
    a alias a1 a1
1435 
    proc a1 {} {
1436 
        interp invokehidden a -global h1
1437 
    }
1438 
    set r [catch {interp eval a p1} msg]
1439 
    interp delete a
1440 
    list $r $msg
1441 
} {0 91}
1442 
test interp-20.45 {interp hide vs namespaces} {
1443 
    catch {interp delete a}
1444 
    interp create a
1445 
    a eval {
1446 
        namespace eval foo {}
1447 
        proc foo::x {} {}
1448 
    }
1449 
    set l [list [catch {interp hide a foo::x} msg] $msg]
1450 
    interp delete a
1451 
    set l
1452 
} {1 {cannot use namespace qualifiers as hidden commandtoken (rename)}}
1453 
test interp-20.46 {interp hide vs namespaces} {
1454 
    catch {interp delete a}
1455 
    interp create a
1456 
    a eval {
1457 
        namespace eval foo {}
1458 
        proc foo::x {} {}
1459 
    }
1460 
    set l [list [catch {interp hide a foo::x x} msg] $msg]
1461 
    interp delete a
1462 
    set l
1463 
} {1 {can only hide global namespace commands (use rename then hide)}}
1464 
test interp-20.47 {interp hide vs namespaces} {
1465 
    catch {interp delete a}
1466 
    interp create a
1467 
    a eval {
1468 
        proc x {} {}
1469 
    }
1470 
    set l [list [catch {interp hide a x foo::x} msg] $msg]
1471 
    interp delete a
1472 
    set l
1473 
} {1 {cannot use namespace qualifiers as hidden commandtoken (rename)}}
1474 
test interp-20.48 {interp hide vs namespaces} {
1475 
    catch {interp delete a}
1476 
    interp create a
1477 
    a eval {
1478 
        namespace eval foo {}
1479 
        proc foo::x {} {}
1480 
    }
1481 
    set l [list [catch {interp hide a foo::x bar::x} msg] $msg]
1482 
    interp delete a
1483 
    set l
1484 
} {1 {cannot use namespace qualifiers as hidden commandtoken (rename)}}
1485 
 
1486 
test interp-21.1 {interp hidden} {
1487 
    interp hidden {}
1488 
} ""
1489 
test interp-21.2 {interp hidden} {
1490 
    interp hidden
1491 
} ""
1492 
test interp-21.3 {interp hidden vs interp hide, interp expose} {
1493 
    set l ""
1494 
    lappend l [interp hidden]
1495 
    interp hide {} pwd
1496 
    lappend l [interp hidden]
1497 
    interp expose {} pwd
1498 
    lappend l [interp hidden]
1499 
    set l
1500 
} {{} pwd {}}
1501 
test interp-21.4 {interp hidden} {
1502 
    catch {interp delete a}
1503 
    interp create a
1504 
    set l [interp hidden a]
1505 
    interp delete a
1506 
    set l
1507 
} ""
1508 
test interp-21.5 {interp hidden} {
1509 
    catch {interp delete a}
1510 
    interp create -safe a
1511 
    set l [lsort [interp hidden a]]
1512 
    interp delete a
1513 
    set l
1514 
} $hidden_cmds
1515 
test interp-21.6 {interp hidden vs interp hide, interp expose} {
1516 
    catch {interp delete a}
1517 
    interp create a
1518 
    set l ""
1519 
    lappend l [interp hidden a]
1520 
    interp hide a pwd
1521 
    lappend l [interp hidden a]
1522 
    interp expose a pwd
1523 
    lappend l [interp hidden a]
1524 
    interp delete a
1525 
    set l
1526 
} {{} pwd {}}
1527 
test interp-21.7 {interp hidden} {
1528 
    catch {interp delete a}
1529 
    interp create a
1530 
    set l [a hidden]
1531 
    interp delete a
1532 
    set l
1533 
} ""
1534 
test interp-21.8 {interp hidden} {
1535 
    catch {interp delete a}
1536 
    interp create a -safe
1537 
    set l [lsort [a hidden]]
1538 
    interp delete a
1539 
    set l
1540 
} $hidden_cmds
1541 
test interp-21.9 {interp hidden vs interp hide, interp expose} {
1542 
    catch {interp delete a}
1543 
    interp create a
1544 
    set l ""
1545 
    lappend l [a hidden]
1546 
    a hide pwd
1547 
    lappend l [a hidden]
1548 
    a expose pwd
1549 
    lappend l [a hidden]
1550 
    interp delete a
1551 
    set l
1552 
} {{} pwd {}}
1553 
 
1554 
test interp-22.1 {testing interp marktrusted} {
1555 
    catch {interp delete a}
1556 
    interp create a
1557 
    set l ""
1558 
    lappend l [a issafe]
1559 
    lappend l [a marktrusted]
1560 
    lappend l [a issafe]
1561 
    interp delete a
1562 
    set l
1563 
} {0 {} 0}
1564 
test interp-22.2 {testing interp marktrusted} {
1565 
    catch {interp delete a}
1566 
    interp create a
1567 
    set l ""
1568 
    lappend l [interp issafe a]
1569 
    lappend l [interp marktrusted a]
1570 
    lappend l [interp issafe a]
1571 
    interp delete a
1572 
    set l
1573 
} {0 {} 0}
1574 
test interp-22.3 {testing interp marktrusted} {
1575 
    catch {interp delete a}
1576 
    interp create a -safe
1577 
    set l ""
1578 
    lappend l [a issafe]
1579 
    lappend l [a marktrusted]
1580 
    lappend l [a issafe]
1581 
    interp delete a
1582 
    set l
1583 
} {1 {} 0}
1584 
test interp-22.4 {testing interp marktrusted} {
1585 
    catch {interp delete a}
1586 
    interp create a -safe
1587 
    set l ""
1588 
    lappend l [interp issafe a]
1589 
    lappend l [interp marktrusted a]
1590 
    lappend l [interp issafe a]
1591 
    interp delete a
1592 
    set l
1593 
} {1 {} 0}
1594 
test interp-22.5 {testing interp marktrusted} {
1595 
    catch {interp delete a}
1596 
    interp create a -safe
1597 
    interp create {a b}
1598 
    catch {a eval {interp marktrusted b}} msg
1599 
    interp delete a
1600 
    set msg
1601 
} {"interp marktrusted" can only be invoked from a trusted interpreter}
1602 
test interp-22.6 {testing interp marktrusted} {
1603 
    catch {interp delete a}
1604 
    interp create a -safe
1605 
    interp create {a b}
1606 
    catch {a eval {b marktrusted}} msg
1607 
    interp delete a
1608 
    set msg
1609 
} {"b marktrusted" can only be invoked from a trusted interpreter}
1610 
test interp-22.7 {testing interp marktrusted} {
1611 
    catch {interp delete a}
1612 
    interp create a -safe
1613 
    set l ""
1614 
    lappend l [interp issafe a]
1615 
    interp marktrusted a
1616 
    interp create {a b}
1617 
    lappend l [interp issafe a]
1618 
    lappend l [interp issafe {a b}]
1619 
    interp delete a
1620 
    set l
1621 
} {1 0 0}
1622 
test interp-22.8 {testing interp marktrusted} {
1623 
    catch {interp delete a}
1624 
    interp create a -safe
1625 
    set l ""
1626 
    lappend l [interp issafe a]
1627 
    interp create {a b}
1628 
    lappend l [interp issafe {a b}]
1629 
    interp marktrusted a
1630 
    interp create {a c}
1631 
    lappend l [interp issafe a]
1632 
    lappend l [interp issafe {a c}]
1633 
    interp delete a
1634 
    set l
1635 
} {1 1 0 0}
1636 
test interp-22.9 {testing interp marktrusted} {
1637 
    catch {interp delete a}
1638 
    interp create a -safe
1639 
    set l ""
1640 
    lappend l [interp issafe a]
1641 
    interp create {a b}
1642 
    lappend l [interp issafe {a b}]
1643 
    interp marktrusted {a b}
1644 
    lappend l [interp issafe a]
1645 
    lappend l [interp issafe {a b}]
1646 
    interp create {a b c}
1647 
    lappend l [interp issafe {a b c}]
1648 
    interp delete a
1649 
    set l
1650 
} {1 1 1 0 0}
1651 
 
1652 
test interp-23.1 {testing hiding vs aliases} {
1653 
    catch {interp delete a}
1654 
    interp create a
1655 
    set l ""
1656 
    lappend l [interp hidden a]
1657 
    a alias bar bar
1658 
    lappend l [interp aliases a]
1659 
    lappend l [interp hidden a]
1660 
    a hide bar
1661 
    lappend l [interp aliases a]
1662 
    lappend l [interp hidden a]
1663 
    a alias bar {}
1664 
    lappend l [interp aliases a]
1665 
    lappend l [interp hidden a]
1666 
    interp delete a
1667 
    set l
1668 
} {{} bar {} bar bar {} {}}
1669 
test interp-23.2 {testing hiding vs aliases} {pc || unix} {
1670 
    catch {interp delete a}
1671 
    interp create a -safe
1672 
    set l ""
1673 
    lappend l [lsort [interp hidden a]]
1674 
    a alias bar bar
1675 
    lappend l [interp aliases a]
1676 
    lappend l [lsort [interp hidden a]]
1677 
    a hide bar
1678 
    lappend l [interp aliases a]
1679 
    lappend l [lsort [interp hidden a]]
1680 
    a alias bar {}
1681 
    lappend l [interp aliases a]
1682 
    lappend l [lsort [interp hidden a]]
1683 
    interp delete a
1684 
    set l
1685 
} {{cd exec exit fconfigure file glob load open pwd socket source} bar {cd exec exit fconfigure file glob load open pwd socket source} bar {bar cd exec exit fconfigure file glob load open pwd socket source} {} {cd exec exit fconfigure file glob load open pwd socket source}}
1686 
 
1687 
test interp-23.3 {testing hiding vs aliases} {macOnly} {
1688 
    catch {interp delete a}
1689 
    interp create a -safe
1690 
    set l ""
1691 
    lappend l [lsort [interp hidden a]]
1692 
    a alias bar bar
1693 
    lappend l [interp aliases a]
1694 
    lappend l [lsort [interp hidden a]]
1695 
    a hide bar
1696 
    lappend l [interp aliases a]
1697 
    lappend l [lsort [interp hidden a]]
1698 
    a alias bar {}
1699 
    lappend l [interp aliases a]
1700 
    lappend l [lsort [interp hidden a]]
1701 
    interp delete a
1702 
    set l
1703 
} {{beep cd echo exit fconfigure file glob load ls open pwd socket source} bar {beep cd echo exit fconfigure file glob load ls open pwd socket source} bar {bar beep cd echo exit fconfigure file glob load ls open pwd socket source} {} {beep cd echo exit fconfigure file glob load ls open pwd socket source}}
1704 
 
1705 
test interp-24.1 {result resetting on error} {
1706 
    catch {interp delete a}
1707 
    interp create a
1708 
    proc foo args {error $args}
1709 
    interp alias a foo {} foo
1710 
    set l [interp eval a {
1711 
        set l {}
1712 
        lappend l [catch {foo 1 2 3} msg]
1713 
        lappend l $msg
1714 
        lappend l [catch {foo 3 4 5} msg]
1715 
        lappend l $msg
1716 
        set l
1717 
    }]
1718 
    interp delete a
1719 
    set l
1720 
} {1 {1 2 3} 1 {3 4 5}}
1721 
test interp-24.2 {result resetting on error} {
1722 
    catch {interp delete a}
1723 
    interp create a -safe
1724 
    proc foo args {error $args}
1725 
    interp alias a foo {} foo
1726 
    set l [interp eval a {
1727 
        set l {}
1728 
        lappend l [catch {foo 1 2 3} msg]
1729 
        lappend l $msg
1730 
        lappend l [catch {foo 3 4 5} msg]
1731 
        lappend l $msg
1732 
        set l
1733 
    }]
1734 
    interp delete a
1735 
    set l
1736 
} {1 {1 2 3} 1 {3 4 5}}
1737 
test interp-24.3 {result resetting on error} {
1738 
    catch {interp delete a}
1739 
    interp create a
1740 
    interp create {a b}
1741 
    interp eval a {
1742 
        proc foo args {error $args}
1743 
    }
1744 
    interp alias {a b} foo a foo
1745 
    set l [interp eval {a b} {
1746 
        set l {}
1747 
        lappend l [catch {foo 1 2 3} msg]
1748 
        lappend l $msg
1749 
        lappend l [catch {foo 3 4 5} msg]
1750 
        lappend l $msg
1751 
        set l
1752 
    }]
1753 
    interp delete a
1754 
    set l
1755 
} {1 {1 2 3} 1 {3 4 5}}
1756 
test interp-24.4 {result resetting on error} {
1757 
    catch {interp delete a}
1758 
    interp create a -safe
1759 
    interp create {a b}
1760 
    interp eval a {
1761 
        proc foo args {error $args}
1762 
    }
1763 
    interp alias {a b} foo a foo
1764 
    set l [interp eval {a b} {
1765 
        set l {}
1766 
        lappend l [catch {foo 1 2 3} msg]
1767 
        lappend l $msg
1768 
        lappend l [catch {foo 3 4 5} msg]
1769 
        lappend l $msg
1770 
        set l
1771 
    }]
1772 
    interp delete a
1773 
    set l
1774 
} {1 {1 2 3} 1 {3 4 5}}
1775 
test interp-24.5 {result resetting on error} {
1776 
    catch {interp delete a}
1777 
    catch {interp delete b}
1778 
    interp create a
1779 
    interp create b
1780 
    interp eval a {
1781 
        proc foo args {error $args}
1782 
    }
1783 
    interp alias b foo a foo
1784 
    set l [interp eval b {
1785 
        set l {}
1786 
        lappend l [catch {foo 1 2 3} msg]
1787 
        lappend l $msg
1788 
        lappend l [catch {foo 3 4 5} msg]
1789 
        lappend l $msg
1790 
        set l
1791 
    }]
1792 
    interp delete a
1793 
    set l
1794 
} {1 {1 2 3} 1 {3 4 5}}
1795 
test interp-24.6 {result resetting on error} {
1796 
    catch {interp delete a}
1797 
    catch {interp delete b}
1798 
    interp create a -safe
1799 
    interp create b -safe
1800 
    interp eval a {
1801 
        proc foo args {error $args}
1802 
    }
1803 
    interp alias b foo a foo
1804 
    set l [interp eval b {
1805 
        set l {}
1806 
        lappend l [catch {foo 1 2 3} msg]
1807 
        lappend l $msg
1808 
        lappend l [catch {foo 3 4 5} msg]
1809 
        lappend l $msg
1810 
        set l
1811 
    }]
1812 
    interp delete a
1813 
    set l
1814 
} {1 {1 2 3} 1 {3 4 5}}
1815 
test interp-24.7 {result resetting on error} {
1816 
    catch {interp delete a}
1817 
    interp create a
1818 
    interp eval a {
1819 
        proc foo args {error $args}
1820 
    }
1821 
    set l {}
1822 
    lappend l [catch {interp eval a foo 1 2 3} msg]
1823 
    lappend l $msg
1824 
    lappend l [catch {interp eval a foo 3 4 5} msg]
1825 
    lappend l $msg
1826 
    interp delete a
1827 
    set l
1828 
} {1 {1 2 3} 1 {3 4 5}}
1829 
test interp-24.8 {result resetting on error} {
1830 
    catch {interp delete a}
1831 
    interp create a -safe
1832 
    interp eval a {
1833 
        proc foo args {error $args}
1834 
    }
1835 
    set l {}
1836 
    lappend l [catch {interp eval a foo 1 2 3} msg]
1837 
    lappend l $msg
1838 
    lappend l [catch {interp eval a foo 3 4 5} msg]
1839 
    lappend l $msg
1840 
    interp delete a
1841 
    set l
1842 
} {1 {1 2 3} 1 {3 4 5}}
1843 
test interp-24.9 {result resetting on error} {
1844 
    catch {interp delete a}
1845 
    interp create a
1846 
    interp create {a b}
1847 
    interp eval {a b} {
1848 
        proc foo args {error $args}
1849 
    }
1850 
    interp eval a {
1851 
        proc foo args {
1852 
            eval interp eval b foo $args
1853 
        }
1854 
    }
1855 
    set l {}
1856 
    lappend l [catch {interp eval a foo 1 2 3} msg]
1857 
    lappend l $msg
1858 
    lappend l [catch {interp eval a foo 3 4 5} msg]
1859 
    lappend l $msg
1860 
    interp delete a
1861 
    set l
1862 
} {1 {1 2 3} 1 {3 4 5}}
1863 
test interp-24.10 {result resetting on error} {
1864 
    catch {interp delete a}
1865 
    interp create a -safe
1866 
    interp create {a b}
1867 
    interp eval {a b} {
1868 
        proc foo args {error $args}
1869 
    }
1870 
    interp eval a {
1871 
        proc foo args {
1872 
            eval interp eval b foo $args
1873 
        }
1874 
    }
1875 
    set l {}
1876 
    lappend l [catch {interp eval a foo 1 2 3} msg]
1877 
    lappend l $msg
1878 
    lappend l [catch {interp eval a foo 3 4 5} msg]
1879 
    lappend l $msg
1880 
    interp delete a
1881 
    set l
1882 
} {1 {1 2 3} 1 {3 4 5}}
1883 
test interp-24.11 {result resetting on error} {
1884 
    catch {interp delete a}
1885 
    interp create a
1886 
    interp create {a b}
1887 
    interp eval {a b} {
1888 
        proc foo args {error $args}
1889 
    }
1890 
    interp eval a {
1891 
        proc foo args {
1892 
            set l {}
1893 
            lappend l [catch {eval interp eval b foo $args} msg]
1894 
            lappend l $msg
1895 
            lappend l [catch {eval interp eval b foo $args} msg]
1896 
            lappend l $msg
1897 
            set l
1898 
        }
1899 
    }
1900 
    set l [interp eval a foo 1 2 3]
1901 
    interp delete a
1902 
    set l
1903 
} {1 {1 2 3} 1 {1 2 3}}
1904 
test interp-24.12 {result resetting on error} {
1905 
    catch {interp delete a}
1906 
    interp create a -safe
1907 
    interp create {a b}
1908 
    interp eval {a b} {
1909 
        proc foo args {error $args}
1910 
    }
1911 
    interp eval a {
1912 
        proc foo args {
1913 
            set l {}
1914 
            lappend l [catch {eval interp eval b foo $args} msg]
1915 
            lappend l $msg
1916 
            lappend l [catch {eval interp eval b foo $args} msg]
1917 
            lappend l $msg
1918 
            set l
1919 
        }
1920 
    }
1921 
    set l [interp eval a foo 1 2 3]
1922 
    interp delete a
1923 
    set l
1924 
} {1 {1 2 3} 1 {1 2 3}}
1925 
 
1926 
unset hidden_cmds
1927 
 
1928 
test interp-25.1 {testing aliasing of string commands} {
1929 
    catch {interp delete a}
1930 
    interp create a
1931 
    a alias exec foo            ;# Relies on exec being a string command!
1932 
    interp delete a
1933 
} ""
1934 
 
1935 
 
1936 
# Interps result transmission
1937 
test interp-26.1 {result code transmission 1} {knownBug} {
1938 
    # This test currently fails ! (only ok/error are passed, not the other
1939 
    # codes). Fixing the code is thus needed...  -- dl
1940 
    # (the only other acceptable result list would be
1941 
    #  {-1 0 1 0 3 4 5} because of the way return -code return(=2) works)
1942 
    # test that all the possibles error codes from Tcl get passed
1943 
    catch {interp delete a}
1944 
    interp create a
1945 
    interp eval a {proc ret {code} {return -code $code $code}}
1946 
    set res {}
1947 
    # use a for so if a return -code break 'escapes' we would notice
1948 
    for {set code -1} {$code<=5} {incr code} {
1949 
        lappend res [catch {interp eval a ret $code} msg]
1950 
    }
1951 
    interp delete a
1952 
    set res
1953 
} {-1 0 1 2 3 4 5}
1954 
 
1955 
test interp-26.2 {result code transmission 2} {knownBug} {
1956 
    # This test currently fails ! (error is cleared)
1957 
    # Code fixing is needed...  -- dl
1958 
    # (the only other acceptable result list would be
1959 
    #  {-1 0 1 0 3 4 5} because of the way return -code return(=2) works)
1960 
    # test that all the possibles error codes from Tcl get passed
1961 
    set interp [interp create];
1962 
    proc MyTestAlias {interp args} {
1963 
        global aliasTrace;
1964 
        lappend aliasTrace $args;
1965 
        eval interp invokehidden [list $interp] $args
1966 
    }
1967 
    foreach c {return} {
1968 
        interp hide $interp  $c;
1969 
        interp alias $interp $c {} MyTestAlias $interp $c;
1970 
    }
1971 
    interp eval $interp {proc ret {code} {return -code $code $code}}
1972 
    set res {}
1973 
    set aliasTrace {}
1974 
    for {set code -1} {$code<=5} {incr code} {
1975 
        lappend res [catch {interp eval $interp ret $code} msg]
1976 
    }
1977 
    interp delete $interp;
1978 
    list $res
1979 
} {-1 0 1 2 3 4 5}
1980 
 
1981 
test interp-26.3 {errorInfo transmission : regular interps} {
1982 
    set interp [interp create];
1983 
    proc MyError {secret} {
1984 
        return -code error "msg"
1985 
    }
1986 
    proc MyTestAlias {interp args} {
1987 
        MyError "some secret"
1988 
    }
1989 
    interp alias $interp test {} MyTestAlias $interp;
1990 
    set res [interp eval $interp {catch test;set errorInfo}]
1991 
    interp delete $interp;
1992 
    set res
1993 
} {msg
1994 
    while executing
1995 
"MyError "some secret""
1996 
    (procedure "test" line 2)
1997 
    invoked from within
1998 
"catch test"}
1999 
 
2000 
test interp-26.4 {errorInfo transmission : safe interps} {knownBug} {
2001 
    # this test fails because the errorInfo is fully transmitted
2002 
    # whether the interp is safe or not. this is maybe a feature
2003 
    # and not a bug.
2004 
    set interp [interp create -safe];
2005 
    proc MyError {secret} {
2006 
        return -code error "msg"
2007 
    }
2008 
    proc MyTestAlias {interp args} {
2009 
        MyError "some secret"
2010 
    }
2011 
    interp alias $interp test {} MyTestAlias $interp;
2012 
    set res [interp eval $interp {catch test;set errorInfo}]
2013 
    interp delete $interp;
2014 
    set res
2015 
} {msg
2016 
    while executing
2017 
"catch test"}
2018 
 
2019 
# Interps & Namespaces
2020 
test interp-27.1 {interp aliases & namespaces} {
2021 
    set i [interp create];
2022 
    set aliasTrace {};
2023 
    proc tstAlias {args} {
2024 
        global aliasTrace;
2025 
        lappend aliasTrace [list [namespace current] $args];
2026 
    }
2027 
    $i alias foo::bar tstAlias foo::bar;
2028 
    $i eval foo::bar test
2029 
    interp delete $i
2030 
    set aliasTrace;
2031 
} {{:: {foo::bar test}}}
2032 
 
2033 
test interp-27.2 {interp aliases & namespaces} {
2034 
    set i [interp create];
2035 
    set aliasTrace {};
2036 
    proc tstAlias {args} {
2037 
        global aliasTrace;
2038 
        lappend aliasTrace [list [namespace current] $args];
2039 
    }
2040 
    $i alias foo::bar tstAlias foo::bar;
2041 
    $i eval namespace eval foo {bar test}
2042 
    interp delete $i
2043 
    set aliasTrace;
2044 
} {{:: {foo::bar test}}}
2045 
 
2046 
test interp-27.3 {interp aliases & namespaces} {
2047 
    set i [interp create];
2048 
    set aliasTrace {};
2049 
    proc tstAlias {args} {
2050 
        global aliasTrace;
2051 
        lappend aliasTrace [list [namespace current] $args];
2052 
    }
2053 
    interp eval $i {namespace eval foo {proc bar {} {error "bar called"}}}
2054 
    interp alias $i foo::bar {} tstAlias foo::bar;
2055 
    interp eval $i {namespace eval foo {bar test}}
2056 
    interp delete $i
2057 
    set aliasTrace;
2058 
} {{:: {foo::bar test}}}
2059 
 
2060 
test interp-27.4 {interp aliases & namespaces} {
2061 
    set i [interp create];
2062 
    namespace eval foo2 {
2063 
        variable aliasTrace {};
2064 
        proc bar {args} {
2065 
            variable aliasTrace;
2066 
            lappend aliasTrace [list [namespace current] $args];
2067 
        }
2068 
    }
2069 
    $i alias foo::bar foo2::bar foo::bar;
2070 
    $i eval namespace eval foo {bar test}
2071 
    set r $foo2::aliasTrace;
2072 
    namespace delete foo2;
2073 
    set r
2074 
} {{::foo2 {foo::bar test}}}
2075 
 
2076 
# the following tests are commented out while we don't support
2077 
# hiding in namespaces
2078 
 
2079 
# test interp-27.5 {interp hidden & namespaces} {
2080 
#    set i [interp create];
2081 
#    interp eval $i {
2082 
#       namespace eval foo {
2083 
#           proc bar {args} {
2084 
#               return "bar called ([namespace current]) ($args)"
2085 
#           }
2086 
#       }
2087 
#    }
2088 
#    set res [list [interp eval $i {namespace eval foo {bar test1}}]]
2089 
#    interp hide $i foo::bar;
2090 
#    lappend res [list [catch {interp eval $i {namespace eval foo {bar test2}}} msg] $msg]
2091 
#    interp delete $i;
2092 
#    set res;
2093 
#} {{bar called (::foo) (test1)} {1 {invalid command name "bar"}}}
2094 
 
2095 
# test interp-27.6 {interp hidden & aliases & namespaces} {
2096 
#     set i [interp create];
2097 
#     set v root-master;
2098 
#     namespace eval foo {
2099 
#       variable v foo-master;
2100 
#       proc bar {interp args} {
2101 
#           variable v;
2102 
#           list "master bar called ($v) ([namespace current]) ($args)"\
2103 
#                   [interp invokehidden $interp foo::bar $args];
2104 
#       }
2105 
#     }
2106 
#     interp eval $i {
2107 
#       namespace eval foo {
2108 
#           namespace export *
2109 
#           variable v foo-slave;
2110 
#           proc bar {args} {
2111 
#               variable v;
2112 
#               return "slave bar called ($v) ([namespace current]) ($args)"
2113 
#           }
2114 
#       }
2115 
#     }
2116 
#     set res [list [interp eval $i {namespace eval foo {bar test1}}]]
2117 
#     $i hide foo::bar;
2118 
#     $i alias foo::bar foo::bar $i;
2119 
#     set res [concat $res [interp eval $i {
2120 
#       set v root-slave;
2121 
#       namespace eval test {
2122 
#           variable v foo-test;
2123 
#           namespace import ::foo::*;
2124 
#           bar test2
2125 
#         }
2126 
#     }]]
2127 
#     namespace delete foo;
2128 
#     interp delete $i;
2129 
#     set res
2130 
# } {{slave bar called (foo-slave) (::foo) (test1)} {master bar called (foo-master) (::foo) (test2)} {slave bar called (foo-slave) (::foo) (test2)}}
2131 
 
2132 
 
2133 
# test interp-27.7 {interp hidden & aliases & imports & namespaces} {
2134 
#     set i [interp create];
2135 
#     set v root-master;
2136 
#     namespace eval mfoo {
2137 
#       variable v foo-master;
2138 
#       proc bar {interp args} {
2139 
#           variable v;
2140 
#           list "master bar called ($v) ([namespace current]) ($args)"\
2141 
#                   [interp invokehidden $interp test::bar $args];
2142 
#       }
2143 
#     }
2144 
#     interp eval $i {
2145 
#       namespace eval foo {
2146 
#           namespace export *
2147 
#           variable v foo-slave;
2148 
#           proc bar {args} {
2149 
#               variable v;
2150 
#               return "slave bar called ($v) ([info level 0]) ([uplevel namespace current]) ([namespace current]) ($args)"
2151 
#           }
2152 
#       }
2153 
#       set v root-slave;
2154 
#       namespace eval test {
2155 
#           variable v foo-test;
2156 
#           namespace import ::foo::*;
2157 
#         }
2158 
#     }
2159 
#     set res [list [interp eval $i {namespace eval test {bar test1}}]]
2160 
#     $i hide test::bar;
2161 
#     $i alias test::bar mfoo::bar $i;
2162 
#     set res [concat $res [interp eval $i {test::bar test2}]];
2163 
#     namespace delete mfoo;
2164 
#     interp delete $i;
2165 
#     set res
2166 
# } {{slave bar called (foo-slave) (bar test1) (::test) (::foo) (test1)} {master bar called (foo-master) (::mfoo) (test2)} {slave bar called (foo-slave) (test::bar test2) (::) (::foo) (test2)}}
2167 
 
2168 
#test interp-27.8 {hiding, namespaces and integrity} {
2169 
#    namespace eval foo {
2170 
#       variable v 3;
2171 
#       proc bar {} {variable v; set v}
2172 
#       # next command would currently generate an unknown command "bar" error.
2173 
#       interp hide {} bar;
2174 
#    }
2175 
#    namespace delete foo;
2176 
#    list [catch {interp invokehidden {} foo} msg] $msg;
2177 
#} {1 {invalid hidden command name "foo"}}
2178 
 
2179 
 
2180 
test interp-28.1 {getting fooled by slave's namespace ?} {
2181 
    set i [interp create -safe];
2182 
    proc master {interp args} {interp hide $interp list}
2183 
    $i alias master master $i;
2184 
    set r [interp eval $i {
2185 
        namespace eval foo {
2186 
            proc list {args} {
2187 
                return "dummy foo::list";
2188 
            }
2189 
            master;
2190 
        }
2191 
        info commands list
2192 
    }]
2193 
    interp delete $i;
2194 
    set r
2195 
} {}
2196 
 
2197 
# Tests of recursionlimit
2198 
# We need testsetrecursionlimit so we need Tcltest package
2199 
if {[catch {package require Tcltest} msg]} {
2200 
    puts "This application hasn't been compiled with Tcltest"
2201 
    puts "skipping remining interp tests that relies on it."
2202 
} else {
2203 
    #
2204 
test interp-29.1 {recursion limit} {
2205 
    set i [interp create]
2206 
    load {} Tcltest $i
2207 
    set r [interp eval $i {
2208 
        testsetrecursionlimit 50
2209 
        proc p {} {incr ::i; p}
2210 
        set i 0
2211 
        catch p
2212 
        set i
2213 
    }]
2214 
   interp delete $i
2215 
   set r
2216 
} 49
2217 
 
2218 
test interp-29.2 {recursion limit inheritance} {
2219 
    set i [interp create]
2220 
    load {} Tcltest $i
2221 
    set ii [interp eval $i {
2222 
        testsetrecursionlimit 50
2223 
        interp create
2224 
    }]
2225 
    set r [interp eval [list $i $ii] {
2226 
        proc p {} {incr ::i; p}
2227 
        set i 0
2228 
        catch p
2229 
        set i
2230 
    }]
2231 
   interp delete $i
2232 
   set r
2233 
} 49
2234 
 
2235 
#    # Deep recursion (into interps when the regular one fails):
2236 
#    # still crashes...
2237 
#    proc p {} {
2238 
#       if {[catch p ret]} {
2239 
#           catch {
2240 
#               set i [interp create]
2241 
#               interp eval $i [list proc p {} [info body p]]
2242 
#               interp eval $i p
2243 
#           }
2244 
#           interp delete $i
2245 
#           return ok
2246 
#       }
2247 
#       return $ret
2248 
#    }
2249 
#    p
2250 
 
2251 
# more tests needed...
2252 
 
2253 
# Interp & stack
2254 
#test interp-29.1 {interp and stack (info level)} {
2255 
#} {}
2256 
 
2257 
# End of stack-recursion tests
2258 
}
2259 
 
2260 
# This test dumps core in Tcl 8.0.3!
2261 
#test interp-30.1 {deletion of aliases inside namespaces} {
2262 
#    set i [interp create]
2263 
#    $i alias ns::cmd list
2264 
#    $i alias ns::cmd {}
2265 
#} {}
2266 
 
2267 
foreach i [interp slaves] {
2268 
  interp delete $i
2269 
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.