diff options
| -rw-r--r-- | generic/tclBasic.c | 44 | ||||
| -rw-r--r-- | generic/tclCompile.h | 2 | ||||
| -rw-r--r-- | generic/tclLiteral.c | 45 | ||||
| -rw-r--r-- | generic/tclObj.c | 13 | ||||
| -rw-r--r-- | tests/resolver.test | 47 |
5 files changed, 38 insertions, 113 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 53023d8..2ca90fd 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1943,17 +1943,6 @@ 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. @@ -2109,17 +2098,6 @@ Tcl_CreateCommand( 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. @@ -2305,17 +2283,6 @@ Tcl_CreateObjCommand( 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. @@ -2628,17 +2595,6 @@ 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 89cdc59..5db1a01 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1160,8 +1160,6 @@ MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp, 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[]); diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 9922cec..db210cb 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -1004,51 +1004,6 @@ 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, 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 /* *---------------------------------------------------------------------- diff --git a/generic/tclObj.c b/generic/tclObj.c index d3f59ec..54c7bc6 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -4130,6 +4130,7 @@ Tcl_GetCommandFromObj( * global namespace. */ { register ResolvedCmdName *resPtr; + Tcl_Command result = NULL; /* * Get the internal representation, converting to a command type if @@ -4175,11 +4176,14 @@ Tcl_GetCommandFromObj( */ /* 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; } /* @@ -4272,6 +4276,7 @@ TclSetCmdNameObj( return; } } + return; SetCmdNameObj(interp, objPtr, cmdPtr, NULL); } diff --git a/tests/resolver.test b/tests/resolver.test index 9bb4c08..db12b99 100644 --- a/tests/resolver.test +++ b/tests/resolver.test @@ -41,7 +41,8 @@ test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup # 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 @@ -52,13 +53,14 @@ test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup 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 } @@ -67,19 +69,20 @@ test resolver-1.2 {cmdNameObj sharing vs. cmd resolver: proc creation} -setup { } } -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 } @@ -89,18 +92,20 @@ test resolver-1.3 {cmdNameObj sharing vs. cmd resolver: rename} -setup { } } -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 } @@ -111,18 +116,20 @@ test resolver-1.4 {cmdNameObj sharing vs. cmd resolver: interp expose} -setup { } } -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 { @@ -140,17 +147,19 @@ test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -s } } -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 } @@ -160,18 +169,20 @@ test resolver-1.6 {cmdNameObj sharing vs. cmd resolver: interp alias} -setup { } } -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 |