Index: generic/tclBasic.c ================================================================== --- generic/tclBasic.c +++ generic/tclBasic.c @@ -1940,21 +1940,10 @@ "exposed command \"%s\" already exists", cmdName)); Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", NULL); return TCL_ERROR; } - /* - * 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. */ @@ -2107,21 +2096,10 @@ */ ckfree(Tcl_GetHashValue(hPtr)); } } 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. @@ -2303,21 +2281,10 @@ */ ckfree(Tcl_GetHashValue(hPtr)); } } 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. @@ -2625,21 +2592,10 @@ */ TclInvalidateNsCmdLookup(cmdNsPtr); 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 * TclCleanupCommand. Index: generic/tclCompile.h ================================================================== --- generic/tclCompile.h +++ generic/tclCompile.h @@ -1158,12 +1158,10 @@ int flags, int *localIndexPtr, int *isScalarPtr); MODULE_SCOPE void TclPreserveByteCode(ByteCode *codePtr); MODULE_SCOPE void TclReleaseByteCode(ByteCode *codePtr); 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[]); MODULE_SCOPE int TclSortingOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Index: generic/tclLiteral.c ================================================================== --- generic/tclLiteral.c +++ generic/tclLiteral.c @@ -1001,55 +1001,10 @@ if (oldBuckets != tablePtr->staticBuckets) { ckfree(oldBuckets); } } - -/* - *---------------------------------------------------------------------- - * - * 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, name, - strlen(name), -1, NULL, nsPtr, 0, NULL); - - if (literalObjPtr != NULL) { - if (literalObjPtr->typePtr == &tclCmdNameType) { - TclFreeIntRep(literalObjPtr); - } - /* Balance the refcount effects of TclCreateLiteral() above */ - Tcl_IncrRefCount(literalObjPtr); - TclReleaseLiteral(interp, literalObjPtr); - } -} #ifdef TCL_COMPILE_STATS /* *---------------------------------------------------------------------- * Index: generic/tclObj.c ================================================================== --- generic/tclObj.c +++ generic/tclObj.c @@ -4128,10 +4128,11 @@ * looked up in global namespace. Else, looked * up first in the current namespace, then in * global namespace. */ { register ResolvedCmdName *resPtr; + Tcl_Command result = NULL; /* * Get the internal representation, converting to a command type if * needed. The internal representation is a ResolvedCmdName that points to * the actual command. @@ -4173,15 +4174,18 @@ * OK, must create a new internal representation (or fail) as any cache we * had is invalid one way or another. */ /* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */ - if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) { - return NULL; + if (tclCmdNameType.setFromAnyProc(interp, objPtr) == TCL_OK) { + resPtr = objPtr->internalRep.twoPtrValue.ptr1; + if (resPtr) { + result = (Tcl_Command) resPtr->cmdPtr; + } + TclFreeIntRep(objPtr); } - resPtr = objPtr->internalRep.twoPtrValue.ptr1; - return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL); + return result; } /* *---------------------------------------------------------------------- * @@ -4270,10 +4274,11 @@ resPtr = objPtr->internalRep.twoPtrValue.ptr1; if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) { return; } } + return; SetCmdNameObj(interp, objPtr, cmdPtr, NULL); } /* Index: tests/resolver.test ================================================================== --- tests/resolver.test +++ tests/resolver.test @@ -39,11 +39,12 @@ # 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" + set r1 untouched + catch {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 @@ -50,59 +51,63 @@ # the namespace imported cmd. namespace eval :: { namespace import ::ns1::z set r2 [z] } - list $r0 $r1 $::r2 + set r3 [x] + list $r0 $r1 $::r2 $r3 } -cleanup { testinterpresolver down rename ::x "" rename ::y "" namespace delete ::ns1 -} -result {Y Y Z} +} -result {Y untouched Z Y} 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] + set r1 untouched + catch {set r1 [z]} proc ::foo {} { proc ::z {} { return Z } return [z] } - list $r0 $r1 [::foo] + list $r0 $r1 [::foo] [x] } -cleanup { testinterpresolver down rename ::x "" rename ::y "" rename ::foo "" rename ::z "" -} -result {Y Y Z} +} -result {Y untouched Z Y} 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] + set r1 untouched + catch {set r1 [z]} namespace eval :: { rename ::Z ::z set r2 [z] } - list $r0 $r1 $r2 + set r3 [x] + list $r0 $r1 $r2 $r3 } -cleanup { testinterpresolver down rename ::x "" rename ::y "" rename ::z "" -} -result {Y Y Z} +} -result {Y untouched Z Y} 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 } @@ -109,22 +114,24 @@ proc ::x {} { z } } -constraints testinterpresolver -body { set r0 [x] - set r1 [z] + set r1 untouched + catch {set r1 [z]} interp expose {} Z z namespace eval :: { set r2 [z] } - list $r0 $r1 $r2 + set r0 [x] + list $r0 $r1 $r2 $r3 } -cleanup { testinterpresolver down rename ::x "" rename ::y "" rename ::z "" -} -result {Y Y Z} +} -result {Y untouched Z Y} 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 @@ -138,42 +145,46 @@ namespace eval :: { variable r2 "" } } -constraints testinterpresolver -body { set r0 [namespace eval ::ns2 {x}] - set r1 [namespace eval ::ns2 {z}] + set r1 untouched + catch {set r1 [namespace eval ::ns2 {z}]} namespace eval ::ns2 { namespace import ::ns1::z set r2 [z] } - list $r0 $r1 $r2 + set r3 [namespace eval ::ns2 {x}] + list $r0 $r1 $r2 $r3 } -cleanup { testinterpresolver down namespace delete ::ns2 namespace delete ::ns1 -} -result {Y Y Z} +} -result {Y untouched Z Y} 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] + set r1 untouched + catch {set r1 [z]} namespace eval :: { interp alias {} ::z {} ::Z set r2 [z] } - list $r0 $r1 $r2 + set r3 [x] + list $r0 $r1 $r2 $r3 } -cleanup { testinterpresolver down rename ::x "" rename ::y "" rename ::Z "" -} -result {Y Y Z} +} -result {Y untouched Z Y} 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