Attachment "resolver866.patch" to
ticket [d4e7780ca1]
added by
gustafn2
2016-07-21 10:05:48.
Index: generic/tclCompile.c
==================================================================
--- generic/tclCompile.c
+++ generic/tclCompile.c
@@ -1782,11 +1782,36 @@
{
int numBytes;
const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes);
int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes);
Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
+
+ /*
+ * Check, if lookup from the provided Tcl_Obj was successful
+ */
+ if (cmdPtr != NULL) {
+ Tcl_Obj *litObj = TclFetchLiteral(envPtr, cmdLitIdx);
+ Command *litCmdPtr = (Command *)Tcl_GetCommandFromObj(interp, litObj);
+ /*
+ * The fetched literal might come from the global literal pool. It is
+ * not guaranteed, that the passed-in command from the cmdObj is the
+ * same as the command found from the shared literal pool. The results
+ * might differ, when e.g. custom command resolver are used.
+ */
+
+ if (cmdPtr != litCmdPtr) {
+ /*
+ * Turn a shared literal into a private literal that cannot be
+ * shared.
+ */
+ /* fprintf(stderr, "#### CompileCmdLiteral cmdPtr differ, unshare literal %d\n", cmdLitIdx);*/
+ TclHideLiteral(interp, envPtr, cmdLitIdx);
+ cmdLitIdx = TclRegisterLiteral(envPtr, (char *)bytes, numBytes, 0);
+ }
+ }
+
if (cmdPtr) {
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
}
TclEmitPush(cmdLitIdx, envPtr);
}
Index: generic/tclTest.c
==================================================================
--- generic/tclTest.c
+++ generic/tclTest.c
@@ -7293,33 +7293,93 @@
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);
+ Interp *iPtr = (Interp *) interp;
+ CallFrame *varFramePtr = iPtr->varFramePtr;
+ Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ? varFramePtr->procPtr : NULL;
+ Namespace *callerNsPtr = varFramePtr->nsPtr;
+ Tcl_Command resolvedCmdPtr = NULL;
- if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr
- || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) {
- const char *callingCmdName =
+ /*
+ * Just do something special on a cmd literal "z" in two cases:
+ * A) when the caller is a proc "x", and the proc is either in "::" or in "::ns2".
+ * B) the caller's namespace is "ctx1" or "ctx2"
+ */
+ if ( (name[0] == 'z') && (name[1] == '\0') ) {
+ Namespace *ns2NsPtr = (Namespace *) Tcl_FindNamespace(interp, "::ns2", NULL, 0);
+
+ if (procPtr != NULL
+ && ((procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr)
+ || (ns2NsPtr != NULL && procPtr->cmdPtr->nsPtr == ns2NsPtr)
+ )
+ ) {
+ /*
+ * Case A)
+ *
+ * - The context, in which this resolver becomes active, is
+ * determined by the name of the caller proc, which has to be
+ * named "x".
+ *
+ * - To determine the name of the caller proc, the proc is taken
+ * from the topmost stack frame.
+ *
+ * - Note that the context is NOT provided during byte-code
+ * compilation (e.g. in TclProcCompileProc)
+ *
+ * When these conditions hold, this function resolves the
+ * passed-in cmd literal into a cmd "y", which is taken from the
+ * the global namespace (for simplicity).
+ */
+
+ const char *callingCmdName =
Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr);
+
+ if ( callingCmdName[0] == 'x' && callingCmdName[1] == '\0' ) {
+ resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY);
+ }
- if ((callingCmdName[0] == 'x') && (callingCmdName[1] == '\0')
- && (name[0] == 'z') && (name[1] == '\0')) {
- Tcl_Command sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL,
- TCL_GLOBAL_ONLY);
+ } else if (callerNsPtr != NULL) {
+ /*
+ * Case B)
+ *
+ * - The context, in which this resolver becomes active, is
+ * determined by the name of the parent namespace, which has
+ * to be named "ctx1" or "ctx2".
+ *
+ * - To determine the name of the parent namesace, it is taken
+ * from the 2nd highest stack frame.
+ *
+ * - Note that the context can be provided during byte-code
+ * compilation (e.g. in TclProcCompileProc)
+ *
+ * When these conditions hold, this function resolves the
+ * passed-in cmd literal into a cmd "y" or "Y" depending on the
+ * context. The resolved procs are taken from the the global
+ * namespace (for simplicity).
+ */
- if (sourceCmdPtr != NULL) {
- *rPtr = sourceCmdPtr;
- return TCL_OK;
+ CallFrame *parentFramePtr = varFramePtr->callerPtr;
+ char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)";
+
+ if (strcmp(context, "ctx1") == 0 && (name[0] == 'z') && (name[1] == '\0')) {
+ resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY);
+ /* fprintf(stderr, "... y ==> %p\n", resolvedCmdPtr);*/
+
+ } else if (strcmp(context, "ctx2") == 0 && (name[0] == 'z') && (name[1] == '\0')) {
+ resolvedCmdPtr = Tcl_FindCommand(interp, "Y", NULL, TCL_GLOBAL_ONLY);
+ /*fprintf(stderr, "... Y ==> %p\n", resolvedCmdPtr);*/
}
}
+
+ if (resolvedCmdPtr != NULL) {
+ *rPtr = resolvedCmdPtr;
+ return TCL_OK;
+ }
}
+
return TCL_CONTINUE;
}
static int
InterpVarResolver(
@@ -7447,13 +7507,20 @@
"down", "up", NULL
};
int idx;
#define RESOLVER_KEY "testInterpResolver"
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "up|down");
+ if (objc < 2 || objc >3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "up|down ?interp?");
return TCL_ERROR;
+ }
+ if (objc == 3) {
+ interp = Tcl_GetSlave(interp, Tcl_GetString(objv[2]));
+ if (interp == NULL) {
+ Tcl_AppendResult(interp, "provided interpreter not found", NULL);
+ return TCL_ERROR;
+ }
}
if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT,
&idx) != TCL_OK) {
return TCL_ERROR;
}
Index: tests/resolver.test
==================================================================
--- tests/resolver.test
+++ tests/resolver.test
@@ -185,22 +185,137 @@
} -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;
+ 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 slave
+# 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:
