Tcl Source Code

# 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 <[email protected]>
# Copyright (c) 2011 Stefan Sobernig <[email protected]>
#
# 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: