summaryrefslogtreecommitdiffstats
path: root/tests/resolver.test
blob: db524a0292f826abbe4ebc34b345143bba5b9ea1 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
# This test collection covers some unwanted interactions between command
# literal sharing and the use of command resolvers (per-interp) which cause
# command literals to be re-used with their command references being invalid
# in the reusing context.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 2011 Gustaf Neumann <gustaf.neumann@wu.ac.at>
# Copyright (c) 2011 Stefan Sobernig <stefan.sobernig@wu.ac.at>
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

package require tcltest 2
if {"::tcltest" in [namespace children]} {
    namespace import -force ::tcltest::*
}

::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]

testConstraint testinterpresolver [llength [info commands testinterpresolver]]

test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup {
    testinterpresolver up
    namespace eval ::ns1 {
	proc z {} { return Z }
	namespace export z
    }
    proc ::y {} { return Y }
    proc ::x {} {
	z
    }
} -constraints testinterpresolver -body {
    # 1) Have the proc body compiled: During compilation or, alternatively,
    # the first evaluation of the compiled body, the InterpCmdResolver (see
    # tclTest.c) maps the cmd token "z" to "::y"; this mapping is saved in the
    # resulting CmdName Tcl_Obj with the print string "z". The CmdName Tcl_Obj
    # is turned into a command literal shared for a given (here: the global)
    # namespace.
    set r0 [x];			# --> The result of [x] is "Y"
    # 2) After having requested cmd resolution above, we can now use the
    # globally shared CmdName Tcl_Obj "z", now bound to cmd ::y. This is
    # certainly questionable, but defensible
    set r1 [z];			# --> The result of [z] is "Y"
    # 3) We import from the namespace ns1 another z. [namespace import] takes
    # care "shadowed" cmd references, however, till now cmd literals have not
    # been touched. This is, however, necessary since the BC compiler (used in
    # the [namespace eval]) seems to be eager to reuse CmdName Tcl_Objs as cmd
    # literals for a given NS scope. We expect, that r2 is "Z", the result of
    # the namespace imported cmd.
    namespace eval :: {
	namespace import ::ns1::z
	set r2 [z]
    }
    list $r0 $r1 $::r2
} -cleanup {
    testinterpresolver down
    rename ::x ""
    rename ::y ""
    namespace delete ::ns1
} -result {Y Y Z}
test resolver-1.2 {cmdNameObj sharing vs. cmd resolver: proc creation} -setup {
    testinterpresolver up
    proc ::y {} { return Y }
    proc ::x {} {
	z
    }
} -constraints testinterpresolver -body {
    set r0 [x]
    set r1 [z]
    proc ::foo {} {
	proc ::z {} { return Z }
	return [z]
    }
    list $r0 $r1 [::foo]
} -cleanup {
    testinterpresolver down
    rename ::x ""
    rename ::y ""
    rename ::foo ""
    rename ::z ""
} -result {Y Y Z}
test resolver-1.3 {cmdNameObj sharing vs. cmd resolver: rename} -setup {
    testinterpresolver up
    proc ::Z {} { return Z }
    proc ::y {} { return Y }
    proc ::x {} {
	z
    }
} -constraints testinterpresolver -body {
    set r0 [x]
    set r1 [z]
    namespace eval :: {
	rename ::Z ::z
	set r2 [z]
    }
    list $r0 $r1 $r2
} -cleanup {
    testinterpresolver down
    rename ::x ""
    rename ::y ""
    rename ::z ""
} -result {Y Y Z}
test resolver-1.4 {cmdNameObj sharing vs. cmd resolver: interp expose} -setup {
    testinterpresolver up
    proc ::Z {} { return Z }
    interp hide {} Z
    proc ::y {} { return Y }
    proc ::x {} {
	z
    }
} -constraints testinterpresolver -body {
    set r0 [x]
    set r1 [z]
    interp expose {} Z z
    namespace eval :: {
	set r2 [z]
    }
    list $r0 $r1 $r2
} -cleanup {
    testinterpresolver down
    rename ::x ""
    rename ::y ""
    rename ::z ""
} -result {Y Y Z}
test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -setup {
    testinterpresolver up
    namespace eval ::ns1 {
	proc z {} { return Z }
	namespace export z
    }
    proc ::y {} { return Y }
    namespace eval ::ns2 {
	proc x {} {
	    z
	}
    }
    namespace eval :: {
	variable r2 ""
    }
} -constraints testinterpresolver -body {
    list [namespace eval ::ns2 {x}] [namespace eval ::ns2 {z}] [namespace eval ::ns2 {
	namespace import ::ns1::z
	z
    }]
} -cleanup {
    testinterpresolver down
    namespace delete ::ns2
    namespace delete ::ns1
} -result {Y Y Z}
test resolver-1.6 {cmdNameObj sharing vs. cmd resolver: interp alias} -setup {
    testinterpresolver up
    proc ::Z {} { return Z }
    proc ::y {} { return Y }
    proc ::x {} {
	z
    }
} -constraints testinterpresolver -body {
    set r0 [x]
    set r1 [z]
    namespace eval :: {
	interp alias {} ::z {} ::Z
	set r2 [z]
    }
    list $r0 $r1 $r2
} -cleanup {
    testinterpresolver down
    rename ::x ""
    rename ::y ""
    rename ::Z ""
} -result {Y Y Z}

test resolver-2.1 {compiled var resolver: Bug #3383616} -setup {
    testinterpresolver up
    # The compiled var resolver fetches just variables starting with a capital
    # "T" and stores some test information in the resolver-specific resolver
    # var info.
    proc ::x {} {
	set T1 100
	return $T1
    }
} -constraints testinterpresolver -body {
    # Call "x" the first time, causing a byte code compilation of the body.
    # During the compilation the compiled var resolver, the resolve-specific
    # var info is allocated, during the execution of the body, the variable is
    # fetched and cached.
    x
    # During later calls, the cached variable is reused.
    x
    # When the proc is freed, the resolver-specific resolver var info is
    # freed. This did not happen before fix #3383616.
    rename ::x ""
} -cleanup {
    testinterpresolver down
} -result {}


#
# The test resolver-3.1* test bad interactions of resolvers on the "global"
# (per interp) literal pools. A resolver might resolve a cmd literal depending
# on a context differently, whereas the cmd literal sharing assumed that the
# namespace containing the literal solely determines the resolved cmd (and is
# resolver-agnostic).
#
# In order to make the test cases for the per-interpreter cmd literal pool
# reproducable and to minimize interactions between test cases, we use a child
# interpreter per test-case.
#
#
# Testing resolver in namespace-based context "ctx1"
#
test resolver-3.1a {
    interp command resolver,
    resolve literal "z" in proc "x1" in context "ctx1"
} -setup {

    interp create i0
    testinterpresolver up i0
    i0 eval {
	proc y {} { return yy }
	namespace eval ::ns {
	    proc x1 {} { z }
	}
    }
} -constraints testinterpresolver -body {

    set r [i0 eval {namespace eval ::ctx1 {
	::ns::x1
    }}]

    return $r
} -cleanup {
    testinterpresolver down i0
    interp delete i0
} -result {yy}

#
# Testing resolver in namespace-based context "ctx2"
#
test resolver-3.1b {
    interp command resolver,
    resolve literal "z" in proc "x2" in context "ctx2"
} -setup {

    interp create i0
    testinterpresolver up i0
    i0 eval {
	proc Y {} { return YY }
	namespace eval ::ns {
	    proc x2 {} { z }
	}
    }
} -constraints testinterpresolver -body {

    set r [i0 eval {namespace eval ::ctx2 {
	::ns::x2
    }}]

    return $r
} -cleanup {
    testinterpresolver down i0
    interp delete i0
} -result {YY}

#
# Testing resolver in namespace-based context "ctx1" and "ctx2" in the same
# interpreter.
#

test resolver-3.1c {
    interp command resolver,
    resolve literal "z" in proc "x1" in context "ctx1",
    resolve literal "z" in proc "x2" in context "ctx2"

    Test, whether the shared cmd literal created by the first byte-code
    compilation interacts with the second one.
} -setup {

    interp create i0
    testinterpresolver up i0

    i0 eval {
	proc y {} { return yy }
	proc Y {} { return YY }
	namespace eval ::ns {
	    proc x1 {} { z }
	    proc x2 {} { z }
	}
    }

} -constraints testinterpresolver -body {

    set r1 [i0 eval {namespace eval ::ctx1 {
	::ns::x1
    }}]

    set r2 [i0 eval {namespace eval ::ctx2 {
	::ns::x2
    }}]

    set r3 [i0 eval {namespace eval ::ctx1 {
	::ns::x1
    }}]

    return [list $r1 $r2 $r3]
} -cleanup {
    testinterpresolver down i0
    interp delete i0
} -result {yy YY yy}


cleanupTests
return

# Local Variables:
# mode: tcl
# fill-column: 78
# End: