# 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::*
}
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
}
}
} -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: