diff options
Diffstat (limited to 'generic/tclTest.c')
| -rw-r--r-- | generic/tclTest.c | 184 |
1 files changed, 184 insertions, 0 deletions
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 |