summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclCompExpr.c2
-rw-r--r--generic/tclCompile.c16
-rw-r--r--generic/tclCompile.h5
-rw-r--r--generic/tclEnsemble.c9
-rw-r--r--generic/tclInt.h10
-rw-r--r--generic/tclLiteral.c33
-rw-r--r--generic/tclNamesp.c3
-rw-r--r--generic/tclObj.c9
-rw-r--r--generic/tclTest.c104
-rw-r--r--tests/resolver.test141
10 files changed, 279 insertions, 53 deletions
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 4390282..ab5e8af 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -2272,7 +2272,7 @@ CompileExprTree(
Tcl_DStringAppend(&cmdName, p, length);
TclEmitPush(TclRegisterNewCmdLiteral(envPtr,
Tcl_DStringValue(&cmdName),
- Tcl_DStringLength(&cmdName)), envPtr);
+ Tcl_DStringLength(&cmdName), 0), envPtr);
Tcl_DStringFree(&cmdName);
/*
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index c0203dd..4e4ead6 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -1781,10 +1781,20 @@ CompileCmdLiteral(
CompileEnv *envPtr)
{
int numBytes;
- const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes);
- int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes);
- Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
+ const char *bytes;
+ Command *cmdPtr;
+ int cmdLitIdx, extraLiteralFlags = 0;
+
+ cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
+ if (cmdPtr != NULL) {
+ if ((cmdPtr->flags & CMD_VIA_RESOLVER)) {
+ extraLiteralFlags = LITERAL_UNSHARED;
+ }
+ }
+ bytes = Tcl_GetStringFromObj(cmdObj, &numBytes);
+ cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes, extraLiteralFlags);
+
if (cmdPtr) {
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
}
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index d5bc86b..fa76f83 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -1208,6 +1208,7 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
#define LITERAL_ON_HEAP 0x01
#define LITERAL_CMD_NAME 0x02
+#define LITERAL_UNSHARED 0x04
/*
* Form of TclRegisterLiteral with flags == 0. In that case, it is safe to
@@ -1229,8 +1230,8 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
* int length);
*/
-#define TclRegisterNewCmdLiteral(envPtr, bytes, length) \
- TclRegisterLiteral(envPtr, (char *)(bytes), length, LITERAL_CMD_NAME)
+#define TclRegisterNewCmdLiteral(envPtr, bytes, length, extraLiteralFlags) \
+ TclRegisterLiteral(envPtr, (char *)(bytes), length, ((extraLiteralFlags)|LITERAL_CMD_NAME))
/*
* Macro used to manually adjust the stack requirements; used in cases where
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 8e5e410..22c475f 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -3306,7 +3306,7 @@ CompileToInvokedCommand(
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
char *bytes;
- int length, i, numWords, cmdLit;
+ int length, i, numWords, cmdLit, extraLiteralFlags = 0;
DefineLineInformation;
/*
@@ -3349,7 +3349,12 @@ CompileToInvokedCommand(
objPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
bytes = Tcl_GetStringFromObj(objPtr, &length);
- cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length);
+ if (cmdPtr != NULL) {
+ if ((cmdPtr->flags & CMD_VIA_RESOLVER)) {
+ extraLiteralFlags = LITERAL_UNSHARED;
+ }
+ }
+ cmdLit = TclRegisterNewCmdLiteral(envPtr, bytes, length, extraLiteralFlags);
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
TclEmitPush(cmdLit, envPtr);
TclDecrRefCount(objPtr);
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 4f7ea6e..4d3c0b1 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -1677,11 +1677,13 @@ typedef struct Command {
* (these last two flags are defined in tcl.h)
*/
-#define CMD_IS_DELETED 0x1
-#define CMD_TRACE_ACTIVE 0x2
-#define CMD_HAS_EXEC_TRACES 0x4
-#define CMD_COMPILES_EXPANDED 0x8
+#define CMD_IS_DELETED 0x01
+#define CMD_TRACE_ACTIVE 0x02
+#define CMD_HAS_EXEC_TRACES 0x04
+#define CMD_COMPILES_EXPANDED 0x08
#define CMD_REDEF_IN_PROGRESS 0x10
+#define CMD_VIA_RESOLVER 0x20
+
/*
*----------------------------------------------------------------
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c
index 03200ca..864d050 100644
--- a/generic/tclLiteral.c
+++ b/generic/tclLiteral.c
@@ -214,15 +214,16 @@ TclCreateLiteral(
if (globalPtrPtr) {
*globalPtrPtr = globalPtr;
}
- if (flags & LITERAL_ON_HEAP) {
+ if ((flags & LITERAL_ON_HEAP)) {
ckfree(bytes);
}
globalPtr->refCount++;
return objPtr;
}
}
+
if (!newPtr) {
- if (flags & LITERAL_ON_HEAP) {
+ if ((flags & LITERAL_ON_HEAP)) {
ckfree(bytes);
}
return NULL;
@@ -235,13 +236,24 @@ TclCreateLiteral(
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
- if (flags & LITERAL_ON_HEAP) {
+ if ((flags & LITERAL_ON_HEAP)) {
objPtr->bytes = bytes;
objPtr->length = length;
} else {
TclInitStringRep(objPtr, bytes, length);
}
+ if ((flags & LITERAL_UNSHARED)) {
+ /*
+ * Make clear, that no global value is returned
+ */
+ if (globalPtrPtr != NULL) {
+ *globalPtrPtr = NULL;
+ }
+ /*fprintf(stderr, "UNSHARED LITERAL <%s>\n", bytes);*/
+ return objPtr;
+ }
+
#ifdef TCL_COMPILE_DEBUG
if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be",
@@ -417,7 +429,7 @@ TclRegisterLiteral(
* the namespace as the interp's global NS.
*/
- if (flags & LITERAL_CMD_NAME) {
+ if ((flags & LITERAL_CMD_NAME)) {
if ((length >= 2) && (bytes[0] == ':') && (bytes[1] == ':')) {
nsPtr = iPtr->globalNsPtr;
} else {
@@ -426,17 +438,17 @@ TclRegisterLiteral(
} else {
nsPtr = NULL;
}
-
+
/*
* Is it in the interpreter's global literal table? If not, create it.
*/
-
+ globalPtr = NULL;
objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr, flags,
&globalPtr);
objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash);
#ifdef TCL_COMPILE_DEBUG
- if (globalPtr->refCount < 1) {
+ if (globalPtr != NULL && globalPtr->refCount < 1) {
Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d",
"TclRegisterLiteral", (length>60? 60 : length), bytes,
globalPtr->refCount);
@@ -1155,9 +1167,10 @@ TclVerifyLocalLiteralTable(
if (LookupLiteralEntry((Tcl_Interp *) envPtr->iPtr,
localPtr->objPtr) == NULL) {
bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length);
- Tcl_Panic("%s: local literal \"%.*s\" is not global",
- "TclVerifyLocalLiteralTable",
- (length>60? 60 : length), bytes);
+ //Tcl_Panic("%s: local literal \"%.*s\" is not global",
+ // "TclVerifyLocalLiteralTable",
+ // (length>60? 60 : length), bytes);
+ /*fprintf(stderr, "local literal \"%s\" is not global\n",bytes);*/
}
if (localPtr->objPtr->bytes == NULL) {
Tcl_Panic("%s: literal has NULL string rep",
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 5930859..a8d351f 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -2566,7 +2566,9 @@ Tcl_FindCommand(
}
if (result == TCL_OK) {
+ ((Command *)cmd)->flags |= CMD_VIA_RESOLVER;
return cmd;
+
} else if (result != TCL_CONTINUE) {
return NULL;
}
@@ -2658,6 +2660,7 @@ Tcl_FindCommand(
}
if (cmdPtr != NULL) {
+ cmdPtr->flags &= ~CMD_VIA_RESOLVER;
return (Tcl_Command) cmdPtr;
}
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 628c3a7..661ab48 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -4219,7 +4219,10 @@ TclSetCmdNameObj(
const char *name;
if (objPtr->typePtr == &tclCmdNameType) {
- return;
+ resPtr = objPtr->internalRep.twoPtrValue.ptr1;
+ if (resPtr->cmdPtr == cmdPtr) {
+ return;
+ }
}
cmdPtr->refCount++;
@@ -4397,7 +4400,9 @@ SetCmdNameFromAny(
cmdPtr->refCount++;
resPtr = objPtr->internalRep.twoPtrValue.ptr1;
if ((objPtr->typePtr == &tclCmdNameType)
- && resPtr && (resPtr->refCount == 1)) {
+ && resPtr != NULL
+ && (resPtr->refCount == 1)
+ ) {
/*
* Reuse the old ResolvedCmdName struct instead of freeing it
*/
diff --git a/generic/tclTest.c b/generic/tclTest.c
index e33d263..522e966 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -7295,29 +7295,88 @@ InterpCmdResolver(
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 =
+ 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;
+
+ /*
+ * 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);
+ }
+ } 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 ((callingCmdName[0] == 'x') && (callingCmdName[1] == '\0')
- && (name[0] == 'z') && (name[1] == '\0')) {
- Tcl_Command sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL,
- TCL_GLOBAL_ONLY);
+ CallFrame *parentFramePtr = varFramePtr->callerPtr;
+ char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)";
- if (sourceCmdPtr != NULL) {
- *rPtr = sourceCmdPtr;
- return TCL_OK;
+ 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;
}
@@ -7449,10 +7508,17 @@ TestInterpResolverCmd(
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;
diff --git a/tests/resolver.test b/tests/resolver.test
index f3d22e5..01e2e0b 100644
--- a/tests/resolver.test
+++ b/tests/resolver.test
@@ -38,10 +38,12 @@ test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup
# 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
@@ -59,12 +61,12 @@ test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup
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
- }
+ proc ::x {} { z }
} -constraints testinterpresolver -body {
set r0 [x]
set r1 [z]
@@ -80,6 +82,8 @@ test resolver-1.2 {cmdNameObj sharing vs. cmd resolver: proc creation} -setup {
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 }
@@ -101,6 +105,8 @@ test resolver-1.3 {cmdNameObj sharing vs. cmd resolver: rename} -setup {
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 }
@@ -123,6 +129,8 @@ test resolver-1.4 {cmdNameObj sharing vs. cmd resolver: interp expose} -setup {
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 {
@@ -131,9 +139,7 @@ test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -s
}
proc ::y {} { return Y }
namespace eval ::ns2 {
- proc x {} {
- z
- }
+ proc x {} { z }
}
namespace eval :: {
variable r2 ""
@@ -151,13 +157,13 @@ test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -s
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
- }
+ proc ::x {} { z }
} -constraints testinterpresolver -body {
set r0 [x]
set r1 [z]
@@ -187,7 +193,7 @@ test resolver-2.1 {compiled var resolver: Bug #3383616} -setup {
# 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
@@ -196,6 +202,121 @@ test resolver-2.1 {compiled var resolver: Bug #3383616} -setup {
} -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
generated by cgit v0.12 at 2024-11-04 21:28:10 (GMT)