319 lines
8.3 KiB
Plaintext
319 lines
8.3 KiB
Plaintext
# 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.
|
||
|
||
if {"::tcltest" ni [namespace children]} {
|
||
package require tcltest 2.5
|
||
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:
|