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
|
# 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 {
set r0 [namespace eval ::ns2 {x}]
set r1 [namespace eval ::ns2 {z}]
namespace eval ::ns2 {
namespace import ::ns1::z
set r2 [z]
}
list $r0 $r1 $r2
} -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 {}
cleanupTests
return
# Local Variables:
# mode: tcl
# fill-column: 78
# End:
|
