summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2011-10-15 15:57:08 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2011-10-15 15:57:08 (GMT)
commit971594ecc4d41c4f217aa38a911f6858e81ca5d0 (patch)
treeaba5b2a2307e32dbad5b1a6a7ac131837fc5b3b3
parent17f82d2daf4b9ae646c39c2922e7d73a7671ed05 (diff)
downloadtcl-971594ecc4d41c4f217aa38a911f6858e81ca5d0.zip
tcl-971594ecc4d41c4f217aa38a911f6858e81ca5d0.tar.gz
tcl-971594ecc4d41c4f217aa38a911f6858e81ca5d0.tar.bz2
Commit of patch relating to interp resolvers
-rw-r--r--generic/tclBasic.c46
-rw-r--r--generic/tclCompile.h2
-rw-r--r--generic/tclLiteral.c40
-rw-r--r--generic/tclTest.c184
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