From 971594ecc4d41c4f217aa38a911f6858e81ca5d0 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 15 Oct 2011 15:57:08 +0000 Subject: Commit of patch relating to interp resolvers --- generic/tclBasic.c | 46 +++++++++++++ generic/tclCompile.h | 2 + generic/tclLiteral.c | 40 +++++++++++ generic/tclTest.c | 184 +++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 272 insertions(+) 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 -- cgit v0.12 From c340a3859f1dfc7b1e77c4d0db35a94d3463f60d Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 15 Oct 2011 16:48:16 +0000 Subject: And the failing test file too... --- tests/resolver.test | 200 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 200 insertions(+) create mode 100644 tests/resolver.test diff --git a/tests/resolver.test b/tests/resolver.test new file mode 100644 index 0000000..bb9f59d --- /dev/null +++ b/tests/resolver.test @@ -0,0 +1,200 @@ +# This test collection covers some unwanted interactions between command +# literal sharing and the use of command resolvers (per-interp) which cause +# command literals to be re-used with their command references being invalid +# in the reusing context. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# Copyright (c) 2011 Gustaf Neumann +# Copyright (c) 2011 Stefan Sobernig +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require tcltest 2 +if {"::tcltest" in [namespace children]} { + namespace import -force ::tcltest::* +} + +testConstraint testinterpresolver [llength [info commands testinterpresolver]] + +test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup { + testinterpresolver up + namespace eval ::ns1 { + proc z {} { return Z } + namespace export z + } + proc ::y {} { return Y } + proc ::x {} { + z + } +} -constraints testinterpresolver -body { + # 1) Have the proc body compiled: During compilation or, alternatively, + # the first evaluation of the compiled body, the InterpCmdResolver (see + # tclTest.c) maps the cmd token "z" to "::y"; this mapping is saved in the + # resulting CmdName Tcl_Obj with the print string "z". The CmdName Tcl_Obj + # 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 + # the [namespace eval]) seems to be eager to reuse CmdName Tcl_Objs as cmd + # literals for a given NS scope. We expect, that r2 is "Z", the result of + # the namespace imported cmd. + namespace eval :: { + namespace import ::ns1::z + set r2 [z] + } + list $r0 $r1 $::r2 +} -cleanup { + testinterpresolver down + rename ::x "" + 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 + } +} -constraints testinterpresolver -body { + set r0 [x] + set r1 [z] + proc ::foo {} { + proc ::z {} { return Z } + return [z] + } + list $r0 $r1 [::foo] +} -cleanup { + testinterpresolver down + rename ::x "" + rename ::y "" + 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 } + proc ::y {} { return Y } + proc ::x {} { + z + } +} -constraints testinterpresolver -body { + set r0 [x] + set r1 [z] + namespace eval :: { + rename ::Z ::z + set r2 [z] + } + list $r0 $r1 $r2 +} -cleanup { + testinterpresolver down + rename ::x "" + 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 } + interp hide {} Z + proc ::y {} { return Y } + proc ::x {} { + z + } +} -constraints testinterpresolver -body { + set r0 [x] + set r1 [z] + interp expose {} Z z + namespace eval :: { + set r2 [z] + } + list $r0 $r1 $r2 +} -cleanup { + testinterpresolver down + rename ::x "" + 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 { + proc z {} { return Z } + namespace export z + } + proc ::y {} { return Y } + namespace eval ::ns2 { + proc x {} { + z + } + } +} -constraints testinterpresolver -body { + set r0 [namespace eval ::ns2 {x}] + set r1 [namespace eval ::ns2 {z}] + namespace eval ::ns2 { + namespace import ::ns1::z + set r2 [z] + } + list $r0 $r1 $r2 +} -cleanup { + testinterpresolver down + 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 + } +} -constraints testinterpresolver -body { + set r0 [x] + set r1 [z] + namespace eval :: { + interp alias {} ::z {} ::Z + set r2 [z] + } + list $r0 $r1 $r2 +} -cleanup { + testinterpresolver down + rename ::x "" + rename ::y "" + rename ::Z "" +} -result {Y Y Z} + +test resolver-2.1 {compiled var resolver: Bug #3383616} -setup { + testinterpresolver up + # The compiled var resolver fetches just variables starting with a capital + # "T" and stores some test information in the resolver-specific resolver + # var info. + proc ::x {} { + set T1 100 + return $T1 + } +} -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; + # 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 {} + +cleanupTests +return + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: -- cgit v0.12 From af3c0b7aa062161e708224346b62b7e8d6fec876 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 19 Oct 2011 20:21:29 +0000 Subject: Stop warnings and segfault. --- generic/tclTest.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 299ba0e..af467f0 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -7149,7 +7149,7 @@ InterpCmdResolver( varFramePtr->procPtr : NULL; Namespace *ns2NsPtr; - ns2NsPtr = Tcl_FindNamespace(interp, "::ns2", NULL, 0); + ns2NsPtr = (Namespace *)Tcl_FindNamespace(interp, "::ns2", NULL, 0); if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) { @@ -7256,7 +7256,7 @@ MyCompiledVarFetch( * Tcl's FreeVarEntry(); for cleanup, we provide our own HashVarFree(); */ - VarHashRefCount(var); + VarHashRefCount(var) ++; return var; } -- cgit v0.12 From 87f901722efaedd3a6c7b91b25f0d8f90e078649 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 20 Oct 2011 13:50:43 +0000 Subject: Tidying up. --- generic/tclTest.c | 76 +++++++++++++++++++++++++++++++------------------------ 1 file changed, 43 insertions(+), 33 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index af467f0..4027816 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -7134,6 +7134,10 @@ TestparseargsCmd( return TCL_OK; } +/** + * Test harness for command and variable resolvers. + */ + static int InterpCmdResolver( Tcl_Interp *interp, @@ -7142,24 +7146,23 @@ InterpCmdResolver( 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 = (Namespace *)Tcl_FindNamespace(interp, "::ns2", NULL, 0); + 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 = Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr); - if ((*callingCmdName == 'x') && (*(callingCmdName + 1) == '\0') - && (*name == 'z') && (*(name + 1) == '\0')) { - sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL, + if ((callingCmdName[0] == 'x') && (callingCmdName[1] == '\0') + && (name[0] == 'z') && (name[1] == '\0')) { + Tcl_Command sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY); + if (sourceCmdPtr != NULL) { *rPtr = sourceCmdPtr; return TCL_OK; @@ -7177,6 +7180,10 @@ InterpVarResolver( int flags, Tcl_Var *rPtr) { + /* + * Don't resolve the variable; use standard rules. + */ + return TCL_CONTINUE; } @@ -7186,12 +7193,12 @@ typedef struct MyResolvedVarInfo { Tcl_Obj *nameObj; } MyResolvedVarInfo; -static void +static inline void HashVarFree( Tcl_Var var) { if (VarHashRefCount(var) < 2) { - ckfree((char *) var); + ckfree(var); } else { VarHashRefCount(var)--; } @@ -7207,7 +7214,7 @@ MyCompiledVarFree( if (resVarInfo->var) { HashVarFree(resVarInfo->var); } - ckfree((char *)vInfoPtr); + ckfree(vInfoPtr); } #define TclVarHashGetValue(hPtr) \ @@ -7220,20 +7227,19 @@ MyCompiledVarFetch( { 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. - */ + if (var != NULL) { + if (!(((Var *) var)->flags & VAR_DEAD_HASH)) { + /* + * The cached variable is valid, return it. + */ - return var; - } + return var; + } - if (var) { /* * The variable is not valid anymore. Clean it up. */ @@ -7241,8 +7247,7 @@ MyCompiledVarFetch( HashVarFree(var); } - nsPtr = iPtr->globalNsPtr; - hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &nsPtr->varTable, + hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &iPtr->globalNsPtr->varTable, (char *) resVarInfo->nameObj, &isNewVar); if (hPtr) { var = (Tcl_Var) TclVarHashGetValue(hPtr); @@ -7256,7 +7261,7 @@ MyCompiledVarFetch( * Tcl's FreeVarEntry(); for cleanup, we provide our own HashVarFree(); */ - VarHashRefCount(var) ++; + VarHashRefCount(var)++; return var; } @@ -7276,7 +7281,7 @@ InterpCompiledVarResolver( resVarInfo->var = NULL; resVarInfo->nameObj = Tcl_NewStringObj(name, -1); Tcl_IncrRefCount(resVarInfo->nameObj); - *rPtr = (Tcl_ResolvedVarInfo *) resVarInfo; + *rPtr = &resVarInfo->vInfo; return TCL_OK; } return TCL_CONTINUE; @@ -7289,26 +7294,31 @@ TestInterpResolversCmd( int objc, Tcl_Obj *const objv[]) { - const char *option; + static const char *const table[] = { + "down", "up", NULL + }; + int idx; +#define RESOLVER_KEY "testInterpResolver" 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, + if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT, + &idx) != TCL_OK) { + return TCL_ERROR; + } + switch (idx) { + case 1: /* up */ + Tcl_AddInterpResolvers(interp, RESOLVER_KEY, InterpCmdResolver, InterpVarResolver, InterpCompiledVarResolver); - } else if (*option == 'd' && strcmp(option, "down") == 0) { - if (Tcl_RemoveInterpResolvers(interp, "interpResolver") == 0) { + break; + case 0: /*down*/ + if (!Tcl_RemoveInterpResolvers(interp, RESOLVER_KEY)) { 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; } -- cgit v0.12 From 37aa42f79dede55e98bf0684b0163c11dfa27f81 Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 20 Oct 2011 14:24:53 +0000 Subject: ChangeLog entry. --- ChangeLog | 10 ++++++++++ generic/tclTest.c | 6 +++--- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/ChangeLog b/ChangeLog index d219048..a36534d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,13 @@ +2011-10-20 Donal K. Fellows + + * generic/tclLiteral.c (TclInvalidateCmdLiteral): [Bug 3418547]: + Additional code for handling the invalidation of literals. + * generic/tclBasic.c (Tcl_CreateObjCommand, Tcl_CreateCommand) + (TclRenameCommand, Tcl_ExposeCommand): The four additional places that + need extra care when dealing with literals. + * generic/tclTest.c (TestInterpResolverCmd): Additional test machinery + for interpreter resolvers. + 2011-10-15 Venkat Iyer * library/tzdata/America/Sitka : Update to Olson's tzdata2011l * library/tzdata/Pacific/Fiji diff --git a/generic/tclTest.c b/generic/tclTest.c index 4027816..86941c6 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -411,7 +411,7 @@ static int TestHashSystemHashCmd(ClientData clientData, static int TestNRELevels(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestInterpResolversCmd(ClientData clientData, +static int TestInterpResolverCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -678,7 +678,7 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels, NULL, NULL); - Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolversCmd, + Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd, NULL, NULL); if (TclObjTest_Init(interp) != TCL_OK) { @@ -7288,7 +7288,7 @@ InterpCompiledVarResolver( } static int -TestInterpResolversCmd( +TestInterpResolverCmd( ClientData clientData, Tcl_Interp *interp, int objc, -- cgit v0.12