Commit of patch relating to interp resolvers

4 files changed, 272 insertions, 0 deletions

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..299ba0e 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		TestInterpResolversCmd(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", TestInterpResolversCmd,
+	    NULL, NULL);
 
     if (TclObjTest_Init(interp) != TCL_OK) {
 	return TCL_ERROR;
@@ -7129,6 +7134,185 @@ TestparseargsCmd(
     return TCL_OK;
 }
 
+static int
+InterpCmdResolver(
+    Tcl_Interp *interp,
+    const char *name,
+    Tcl_Namespace *context,
+    int flags,
+    Tcl_Command *rPtr)
+{
+    Tcl_Command sourceCmdPtr;
+    Interp *iPtr = (Interp *) interp;
+    CallFrame *varFramePtr = iPtr->varFramePtr;
+    Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ?
+        varFramePtr->procPtr : NULL;
+    Namespace *ns2NsPtr;
+
+    ns2NsPtr = 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 == 'x') && (*(callingCmdName + 1) == '\0')
+                && (*name == 'z') && (*(name + 1) == '\0')) {
+            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)
+{
+    return TCL_CONTINUE;
+}
+
+typedef struct MyResolvedVarInfo {
+    Tcl_ResolvedVarInfo vInfo;  /* This must be the first element. */
+    Tcl_Var var;
+    Tcl_Obj *nameObj;
+} MyResolvedVarInfo;
+
+static void
+HashVarFree(
+    Tcl_Var var)
+{
+    if (VarHashRefCount(var) < 2) {
+        ckfree((char *) 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((char *)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;
+    Namespace *nsPtr;
+    int isNewVar;
+    Interp *iPtr = (Interp *) interp;
+    Tcl_HashEntry *hPtr;
+
+    if (var && !(((Var *)var)->flags & VAR_DEAD_HASH)) {
+        /*
+         * The cached variable is valid, return it.
+         */
+
+        return var;
+    }
+
+    if (var) {
+        /*
+         * The variable is not valid anymore. Clean it up.
+         */
+
+        HashVarFree(var);
+    }
+
+    nsPtr = iPtr->globalNsPtr;
+    hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &nsPtr->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 = (Tcl_ResolvedVarInfo *) resVarInfo;
+ 	return TCL_OK;
+    }
+    return TCL_CONTINUE;
+}
+
+static int
+TestInterpResolversCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    const char *option;
+
+    if (objc != 2) {
+        Tcl_WrongNumArgs(interp, 1, objv, "up|down");
+ 	return TCL_ERROR;
+    }
+    option = TclGetString(objv[1]);
+    if (*option == 'u' && strcmp(option, "up") == 0) {
+        Tcl_AddInterpResolvers(interp, "interpResolver", InterpCmdResolver,
+                InterpVarResolver, InterpCompiledVarResolver);
+    } else if (*option == 'd' && strcmp(option, "down") == 0) {
+        if (Tcl_RemoveInterpResolvers(interp, "interpResolver") == 0) {
+            Tcl_AppendResult(interp, "could not remove the resolver scheme",
+                    NULL);
+            return TCL_ERROR;
+        }
+    } else {
+ 	Tcl_AppendResult(interp, "bad option \"", option,
+                "\": must be 'up' or 'down'", NULL);
+ 	return TCL_ERROR;
+    }
+    return TCL_OK;
+}
+
 /*
  * Local Variables:
  * mode: c