1# This test collection covers some unwanted interactions between command
2# literal sharing and the use of command resolvers (per-interp) which cause
3# command literals to be re-used with their command references being invalid
4# in the reusing context.  Sourcing this file into Tcl runs the tests and
5# generates output for errors.  No output means no errors were found.
6#
7# Copyright © 2011 Gustaf Neumann <gustaf.neumann@wu.ac.at>
8# Copyright © 2011 Stefan Sobernig <stefan.sobernig@wu.ac.at>
9#
10# See the file "license.terms" for information on usage and redistribution of
11# this file, and for a DISCLAIMER OF ALL WARRANTIES.
12
13if {"::tcltest" ni [namespace children]} {
14    package require tcltest 2.5
15    namespace import -force ::tcltest::*
16}
17
18::tcltest::loadTestedCommands
19catch [list package require -exact tcl::test [info patchlevel]]
20
21testConstraint testinterpresolver [llength [info commands testinterpresolver]]
22
23test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup {
24    testinterpresolver up
25    namespace eval ::ns1 {
26	proc z {} { return Z }
27	namespace export z
28    }
29    proc ::y {} { return Y }
30    proc ::x {} {
31	z
32    }
33} -constraints testinterpresolver -body {
34    # 1) Have the proc body compiled: During compilation or, alternatively,
35    # the first evaluation of the compiled body, the InterpCmdResolver (see
36    # tclTest.c) maps the cmd token "z" to "::y"; this mapping is saved in the
37    # resulting CmdName Tcl_Obj with the print string "z". The CmdName Tcl_Obj
38    # is turned into a command literal shared for a given (here: the global)
39    # namespace.
40    set r0 [x];			# --> The result of [x] is "Y"
41    # 2) After having requested cmd resolution above, we can now use the
42    # globally shared CmdName Tcl_Obj "z", now bound to cmd ::y. This is
43    # certainly questionable, but defensible
44    set r1 [z];			# --> The result of [z] is "Y"
45    # 3) We import from the namespace ns1 another z. [namespace import] takes
46    # care "shadowed" cmd references, however, till now cmd literals have not
47    # been touched. This is, however, necessary since the BC compiler (used in
48    # the [namespace eval]) seems to be eager to reuse CmdName Tcl_Objs as cmd
49    # literals for a given NS scope. We expect, that r2 is "Z", the result of
50    # the namespace imported cmd.
51    namespace eval :: {
52	namespace import ::ns1::z
53	set r2 [z]
54    }
55    list $r0 $r1 $::r2
56} -cleanup {
57    testinterpresolver down
58    rename ::x ""
59    rename ::y ""
60    namespace delete ::ns1
61} -result {Y Y Z}
62test resolver-1.2 {cmdNameObj sharing vs. cmd resolver: proc creation} -setup {
63    testinterpresolver up
64    proc ::y {} { return Y }
65    proc ::x {} {
66	z
67    }
68} -constraints testinterpresolver -body {
69    set r0 [x]
70    set r1 [z]
71    proc ::foo {} {
72	proc ::z {} { return Z }
73	return [z]
74    }
75    list $r0 $r1 [::foo]
76} -cleanup {
77    testinterpresolver down
78    rename ::x ""
79    rename ::y ""
80    rename ::foo ""
81    rename ::z ""
82} -result {Y Y Z}
83test resolver-1.3 {cmdNameObj sharing vs. cmd resolver: rename} -setup {
84    testinterpresolver up
85    proc ::Z {} { return Z }
86    proc ::y {} { return Y }
87    proc ::x {} {
88	z
89    }
90} -constraints testinterpresolver -body {
91    set r0 [x]
92    set r1 [z]
93    namespace eval :: {
94	rename ::Z ::z
95	set r2 [z]
96    }
97    list $r0 $r1 $r2
98} -cleanup {
99    testinterpresolver down
100    rename ::x ""
101    rename ::y ""
102    rename ::z ""
103} -result {Y Y Z}
104test resolver-1.4 {cmdNameObj sharing vs. cmd resolver: interp expose} -setup {
105    testinterpresolver up
106    proc ::Z {} { return Z }
107    interp hide {} Z
108    proc ::y {} { return Y }
109    proc ::x {} {
110	z
111    }
112} -constraints testinterpresolver -body {
113    set r0 [x]
114    set r1 [z]
115    interp expose {} Z z
116    namespace eval :: {
117	set r2 [z]
118    }
119    list $r0 $r1 $r2
120} -cleanup {
121    testinterpresolver down
122    rename ::x ""
123    rename ::y ""
124    rename ::z ""
125} -result {Y Y Z}
126test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -setup {
127    testinterpresolver up
128    namespace eval ::ns1 {
129	proc z {} { return Z }
130	namespace export z
131    }
132    proc ::y {} { return Y }
133    namespace eval ::ns2 {
134	proc x {} {
135	    z
136	}
137    }
138    namespace eval :: {
139	variable r2 ""
140    }
141} -constraints testinterpresolver -body {
142    list [namespace eval ::ns2 {x}] [namespace eval ::ns2 {z}] [namespace eval ::ns2 {
143	namespace import ::ns1::z
144	z
145    }]
146} -cleanup {
147    testinterpresolver down
148    namespace delete ::ns2
149    namespace delete ::ns1
150} -result {Y Y Z}
151test resolver-1.6 {cmdNameObj sharing vs. cmd resolver: interp alias} -setup {
152    testinterpresolver up
153    proc ::Z {} { return Z }
154    proc ::y {} { return Y }
155    proc ::x {} {
156	z
157    }
158} -constraints testinterpresolver -body {
159    set r0 [x]
160    set r1 [z]
161    namespace eval :: {
162	interp alias {} ::z {} ::Z
163	set r2 [z]
164    }
165    list $r0 $r1 $r2
166} -cleanup {
167    testinterpresolver down
168    rename ::x ""
169    rename ::y ""
170    rename ::Z ""
171} -result {Y Y Z}
172
173test resolver-2.1 {compiled var resolver: Bug #3383616} -setup {
174    testinterpresolver up
175    # The compiled var resolver fetches just variables starting with a capital
176    # "T" and stores some test information in the resolver-specific resolver
177    # var info.
178    proc ::x {} {
179	set T1 100
180	return $T1
181    }
182} -constraints testinterpresolver -body {
183    # Call "x" the first time, causing a byte code compilation of the body.
184    # During the compilation the compiled var resolver, the resolve-specific
185    # var info is allocated, during the execution of the body, the variable is
186    # fetched and cached.
187    x
188    # During later calls, the cached variable is reused.
189    x
190    # When the proc is freed, the resolver-specific resolver var info is
191    # freed. This did not happen before fix #3383616.
192    rename ::x ""
193} -cleanup {
194    testinterpresolver down
195} -result {}
196
197
198#
199# The test resolver-3.1* test bad interactions of resolvers on the "global"
200# (per interp) literal pools. A resolver might resolve a cmd literal depending
201# on a context differently, whereas the cmd literal sharing assumed that the
202# namespace containing the literal solely determines the resolved cmd (and is
203# resolver-agnostic).
204#
205# In order to make the test cases for the per-interpreter cmd literal pool
206# reproducable and to minimize interactions between test cases, we use a child
207# interpreter per test-case.
208#
209#
210# Testing resolver in namespace-based context "ctx1"
211#
212test resolver-3.1a {
213    interp command resolver,
214    resolve literal "z" in proc "x1" in context "ctx1"
215} -setup {
216
217    interp create i0
218    testinterpresolver up i0
219    i0 eval {
220	proc y {} { return yy }
221	namespace eval ::ns {
222	    proc x1 {} { z }
223	}
224    }
225} -constraints testinterpresolver -body {
226
227    set r [i0 eval {namespace eval ::ctx1 {
228	::ns::x1
229    }}]
230
231    return $r
232} -cleanup {
233    testinterpresolver down i0
234    interp delete i0
235} -result {yy}
236
237#
238# Testing resolver in namespace-based context "ctx2"
239#
240test resolver-3.1b {
241    interp command resolver,
242    resolve literal "z" in proc "x2" in context "ctx2"
243} -setup {
244
245    interp create i0
246    testinterpresolver up i0
247    i0 eval {
248	proc Y {} { return YY }
249	namespace eval ::ns {
250	    proc x2 {} { z }
251	}
252    }
253} -constraints testinterpresolver -body {
254
255    set r [i0 eval {namespace eval ::ctx2 {
256	::ns::x2
257    }}]
258
259    return $r
260} -cleanup {
261    testinterpresolver down i0
262    interp delete i0
263} -result {YY}
264
265#
266# Testing resolver in namespace-based context "ctx1" and "ctx2" in the same
267# interpreter.
268#
269
270test resolver-3.1c {
271    interp command resolver,
272    resolve literal "z" in proc "x1" in context "ctx1",
273    resolve literal "z" in proc "x2" in context "ctx2"
274
275    Test, whether the shared cmd literal created by the first byte-code
276    compilation interacts with the second one.
277} -setup {
278
279    interp create i0
280    testinterpresolver up i0
281
282    i0 eval {
283	proc y {} { return yy }
284	proc Y {} { return YY }
285	namespace eval ::ns {
286	    proc x1 {} { z }
287	    proc x2 {} { z }
288	}
289    }
290
291} -constraints testinterpresolver -body {
292
293    set r1 [i0 eval {namespace eval ::ctx1 {
294	::ns::x1
295    }}]
296
297    set r2 [i0 eval {namespace eval ::ctx2 {
298	::ns::x2
299    }}]
300
301    set r3 [i0 eval {namespace eval ::ctx1 {
302	::ns::x1
303    }}]
304
305    return [list $r1 $r2 $r3]
306} -cleanup {
307    testinterpresolver down i0
308    interp delete i0
309} -result {yy YY yy}
310
311
312cleanupTests
313return
314
315# Local Variables:
316# mode: tcl
317# fill-column: 78
318# End:
319