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