summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog23
-rw-r--r--generic/tclBasic.c46
-rw-r--r--generic/tclCompile.h2
-rw-r--r--generic/tclLiteral.c40
-rw-r--r--generic/tclTest.c194
-rw-r--r--tests/resolver.test200
6 files changed, 499 insertions, 6 deletions
diff --git a/ChangeLog b/ChangeLog
index 5cf8570..ccecfcd 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,19 +1,30 @@
+2011-10-20 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclLiteral.c (TclInvalidateCmdLiteral): [Bug 3418547]:
+ Additional code for handling the invalidation of literals.
+ * generic/tclBasic.c (Tcl_CreateObjCommand, Tcl_CreateCommand)
+ (TclRenameCommand, Tcl_ExposeCommand): The four additional places that
+ need extra care when dealing with literals.
+ * generic/tclTest.c (TestInterpResolverCmd): Additional test machinery
+ for interpreter resolvers.
+
2011-10-18 Reinhard Max <max@suse.de>
- * library/clock.tcl (::tcl::clock::GetSystemTimeZone): Cache the
- time zone only if it was detected by one of the expensive
- methods. Otherwise after unsetting TCL_TZ or TZ the previous value
- will still be used.
+ * library/clock.tcl (::tcl::clock::GetSystemTimeZone): Cache the time
+ zone only if it was detected by one of the expensive methods.
+ Otherwise after unsetting TCL_TZ or TZ the previous value will still
+ be used.
2011-10-15 Venkat Iyer <venkat@comit.com>
+
* library/tzdata/America/Sitka : Update to Olson's tzdata2011l
* library/tzdata/Pacific/Fiji
* library/tzdata/Asia/Hebron (New)
2011-10-11 Jan Nijtmans <nijtmans@users.sf.net>
- * win/tclWinFile.c: [Bug 2935503] Incorrect mode field
- returned by file stat command
+ * win/tclWinFile.c: [Bug 2935503]: Incorrect mode field returned by
+ [file stat] command.
2011-10-09 Donal K. Fellows <dkf@users.sf.net>
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 9758449..d10e8e6 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -1922,6 +1922,17 @@ Tcl_ExposeCommand(
}
/*
+ * Command resolvers (per-interp, per-namespace) might have resolved to a
+ * command for the given namespace scope with this command not being
+ * registered with the namespace's command table. During BC compilation,
+ * the so-resolved command turns into a CmdName literal. Without
+ * invalidating a possible CmdName literal here explicitly, such literals
+ * keep being reused while pointing to overhauled commands.
+ */
+
+ TclInvalidateCmdLiteral(interp, cmdName, nsPtr);
+
+ /*
* The list of command exported from the namespace might have changed.
* However, we do not need to recompute this just yet; next time we need
* the info will be soon enough.
@@ -2069,6 +2080,18 @@ Tcl_CreateCommand(
}
} else {
/*
+ * Command resolvers (per-interp, per-namespace) might have resolved
+ * to a command for the given namespace scope with this command not
+ * being registered with the namespace's command table. During BC
+ * compilation, the so-resolved command turns into a CmdName literal.
+ * Without invalidating a possible CmdName literal here explicitly,
+ * such literals keep being reused while pointing to overhauled
+ * commands.
+ */
+
+ TclInvalidateCmdLiteral(interp, tail, nsPtr);
+
+ /*
* The list of command exported from the namespace might have changed.
* However, we do not need to recompute this just yet; next time we
* need the info will be soon enough.
@@ -2242,6 +2265,18 @@ Tcl_CreateObjCommand(
}
} else {
/*
+ * Command resolvers (per-interp, per-namespace) might have resolved
+ * to a command for the given namespace scope with this command not
+ * being registered with the namespace's command table. During BC
+ * compilation, the so-resolved command turns into a CmdName literal.
+ * Without invalidating a possible CmdName literal here explicitly,
+ * such literals keep being reused while pointing to overhauled
+ * commands.
+ */
+
+ TclInvalidateCmdLiteral(interp, tail, nsPtr);
+
+ /*
* The list of command exported from the namespace might have changed.
* However, we do not need to recompute this just yet; next time we
* need the info will be soon enough.
@@ -2551,6 +2586,17 @@ TclRenameCommand(
TclInvalidateNsCmdLookup(cmdPtr->nsPtr);
/*
+ * Command resolvers (per-interp, per-namespace) might have resolved to a
+ * command for the given namespace scope with this command not being
+ * registered with the namespace's command table. During BC compilation,
+ * the so-resolved command turns into a CmdName literal. Without
+ * invalidating a possible CmdName literal here explicitly, such literals
+ * keep being reused while pointing to overhauled commands.
+ */
+
+ TclInvalidateCmdLiteral(interp, newTail, cmdPtr->nsPtr);
+
+ /*
* Script for rename traces can delete the command "oldName". Therefore
* increment the reference count for cmdPtr so that it's Command structure
* is freed only towards the end of this function by calling
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index e80a710..58663fd 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -960,6 +960,8 @@ MODULE_SCOPE void TclRegisterAuxDataType(const AuxDataType *typePtr);
MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr,
char *bytes, int length, int flags);
MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr);
+MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp,
+ const char *name, Namespace *nsPtr);
MODULE_SCOPE int TclSingleOpCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c
index 3a9f8e1..441ea91 100644
--- a/generic/tclLiteral.c
+++ b/generic/tclLiteral.c
@@ -936,6 +936,46 @@ RebuildLiteralTable(
}
}
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInvalidateCmdLiteral --
+ *
+ * Invalidate a command literal entry, if present in the literal hash
+ * tables, by resetting its internal representation. This invalidation
+ * leaves it in the literal tables and in existing literal arrays. As a
+ * result, existing references continue to work but we force a fresh
+ * command look-up upon the next use (see, in particular,
+ * TclSetCmdNameObj()).
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Resets the internal representation of the CmdName Tcl_Obj
+ * using TclFreeIntRep().
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclInvalidateCmdLiteral(
+ Tcl_Interp *interp, /* Interpreter for which to invalidate a
+ * command literal. */
+ const char *name, /* Points to the start of the cmd literal
+ * name. */
+ Namespace *nsPtr) /* The namespace for which to lookup and
+ * invalidate a cmd literal. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name,
+ strlen(name), -1, NULL, nsPtr, 0, NULL);
+
+ if (literalObjPtr != NULL && literalObjPtr->typePtr == &tclCmdNameType) {
+ TclFreeIntRep(literalObjPtr);
+ }
+}
+
#ifdef TCL_COMPILE_STATS
/*
*----------------------------------------------------------------------
diff --git a/generic/tclTest.c b/generic/tclTest.c
index cbebacd..86941c6 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -411,6 +411,9 @@ static int TestHashSystemHashCmd(ClientData clientData,
static int TestNRELevels(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+static int TestInterpResolverCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static const Tcl_Filesystem testReportingFilesystem = {
"reporting",
@@ -675,6 +678,8 @@ Tcltest_Init(
Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd,
+ NULL, NULL);
if (TclObjTest_Init(interp) != TCL_OK) {
return TCL_ERROR;
@@ -7129,6 +7134,195 @@ TestparseargsCmd(
return TCL_OK;
}
+/**
+ * Test harness for command and variable resolvers.
+ */
+
+static int
+InterpCmdResolver(
+ Tcl_Interp *interp,
+ const char *name,
+ Tcl_Namespace *context,
+ int flags,
+ Tcl_Command *rPtr)
+{
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *varFramePtr = iPtr->varFramePtr;
+ Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ?
+ varFramePtr->procPtr : NULL;
+ Namespace *ns2NsPtr = (Namespace *)
+ Tcl_FindNamespace(interp, "::ns2", NULL, 0);
+
+ if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr
+ || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) {
+ const char *callingCmdName =
+ Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr);
+
+ if ((callingCmdName[0] == 'x') && (callingCmdName[1] == '\0')
+ && (name[0] == 'z') && (name[1] == '\0')) {
+ Tcl_Command sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL,
+ TCL_GLOBAL_ONLY);
+
+ if (sourceCmdPtr != NULL) {
+ *rPtr = sourceCmdPtr;
+ return TCL_OK;
+ }
+ }
+ }
+ return TCL_CONTINUE;
+}
+
+static int
+InterpVarResolver(
+ Tcl_Interp *interp,
+ const char *name,
+ Tcl_Namespace *context,
+ int flags,
+ Tcl_Var *rPtr)
+{
+ /*
+ * Don't resolve the variable; use standard rules.
+ */
+
+ return TCL_CONTINUE;
+}
+
+typedef struct MyResolvedVarInfo {
+ Tcl_ResolvedVarInfo vInfo; /* This must be the first element. */
+ Tcl_Var var;
+ Tcl_Obj *nameObj;
+} MyResolvedVarInfo;
+
+static inline void
+HashVarFree(
+ Tcl_Var var)
+{
+ if (VarHashRefCount(var) < 2) {
+ ckfree(var);
+ } else {
+ VarHashRefCount(var)--;
+ }
+}
+
+static void
+MyCompiledVarFree(
+ Tcl_ResolvedVarInfo *vInfoPtr)
+{
+ MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vInfoPtr;
+
+ Tcl_DecrRefCount(resVarInfo->nameObj);
+ if (resVarInfo->var) {
+ HashVarFree(resVarInfo->var);
+ }
+ ckfree(vInfoPtr);
+}
+
+#define TclVarHashGetValue(hPtr) \
+ ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
+
+static Tcl_Var
+MyCompiledVarFetch(
+ Tcl_Interp *interp,
+ Tcl_ResolvedVarInfo *vinfoPtr)
+{
+ MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vinfoPtr;
+ Tcl_Var var = resVarInfo->var;
+ int isNewVar;
+ Interp *iPtr = (Interp *) interp;
+ Tcl_HashEntry *hPtr;
+
+ if (var != NULL) {
+ if (!(((Var *) var)->flags & VAR_DEAD_HASH)) {
+ /*
+ * The cached variable is valid, return it.
+ */
+
+ return var;
+ }
+
+ /*
+ * The variable is not valid anymore. Clean it up.
+ */
+
+ HashVarFree(var);
+ }
+
+ hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &iPtr->globalNsPtr->varTable,
+ (char *) resVarInfo->nameObj, &isNewVar);
+ if (hPtr) {
+ var = (Tcl_Var) TclVarHashGetValue(hPtr);
+ } else {
+ var = NULL;
+ }
+ resVarInfo->var = var;
+
+ /*
+ * Increment the reference counter to avoid ckfree() of the variable in
+ * Tcl's FreeVarEntry(); for cleanup, we provide our own HashVarFree();
+ */
+
+ VarHashRefCount(var)++;
+ return var;
+}
+
+static int
+InterpCompiledVarResolver(
+ Tcl_Interp *interp,
+ const char *name,
+ int length,
+ Tcl_Namespace *context,
+ Tcl_ResolvedVarInfo **rPtr)
+{
+ if (*name == 'T') {
+ MyResolvedVarInfo *resVarInfo = ckalloc(sizeof(MyResolvedVarInfo));
+
+ resVarInfo->vInfo.fetchProc = MyCompiledVarFetch;
+ resVarInfo->vInfo.deleteProc = MyCompiledVarFree;
+ resVarInfo->var = NULL;
+ resVarInfo->nameObj = Tcl_NewStringObj(name, -1);
+ Tcl_IncrRefCount(resVarInfo->nameObj);
+ *rPtr = &resVarInfo->vInfo;
+ return TCL_OK;
+ }
+ return TCL_CONTINUE;
+}
+
+static int
+TestInterpResolverCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ static const char *const table[] = {
+ "down", "up", NULL
+ };
+ int idx;
+#define RESOLVER_KEY "testInterpResolver"
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "up|down");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT,
+ &idx) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (idx) {
+ case 1: /* up */
+ Tcl_AddInterpResolvers(interp, RESOLVER_KEY, InterpCmdResolver,
+ InterpVarResolver, InterpCompiledVarResolver);
+ break;
+ case 0: /*down*/
+ if (!Tcl_RemoveInterpResolvers(interp, RESOLVER_KEY)) {
+ Tcl_AppendResult(interp, "could not remove the resolver scheme",
+ NULL);
+ return TCL_ERROR;
+ }
+ }
+ return TCL_OK;
+}
+
/*
* Local Variables:
* mode: c
diff --git a/tests/resolver.test b/tests/resolver.test
new file mode 100644
index 0000000..bb9f59d
--- /dev/null
+++ b/tests/resolver.test
@@ -0,0 +1,200 @@
+# 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: