diff options
author | dkf <donal.k.fellows@manchester.ac.uk> | 2024-08-07 09:17:31 (GMT) |
---|---|---|
committer | dkf <donal.k.fellows@manchester.ac.uk> | 2024-08-07 09:17:31 (GMT) |
commit | 476c939e94ffd639482d820eafa35f252abbd38e (patch) | |
tree | 24eab4353f1cb8fbd102545c2c5d6d6e29fa5107 | |
parent | 2e730cf19d436075290fcba3390f76b620d18cb4 (diff) | |
parent | 700bdf53e3244f96e9d9ee8fcc33b13103e023b1 (diff) | |
download | tcl-476c939e94ffd639482d820eafa35f252abbd38e.zip tcl-476c939e94ffd639482d820eafa35f252abbd38e.tar.gz tcl-476c939e94ffd639482d820eafa35f252abbd38e.tar.bz2 |
An imperfect fix for [2da1cb0c80] given that can't do the right thing
-rw-r--r-- | generic/tclOOBasic.c | 33 | ||||
-rw-r--r-- | tests/oo.test | 25 |
2 files changed, 45 insertions, 13 deletions
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index ac90e36..5f21203 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -738,12 +738,14 @@ TclOO_Object_VarName( Tcl_Obj *varNamePtr, *argPtr; CallFrame *framePtr = ((Interp *) interp)->varFramePtr; const char *arg; + Tcl_Namespace *namespacePtr; if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "varName"); return TCL_ERROR; } + namespacePtr = Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)); argPtr = objv[objc-1]; arg = TclGetString(argPtr); @@ -759,9 +761,6 @@ TclOO_Object_VarName( if (arg[0] == ':' && arg[1] == ':') { varNamePtr = argPtr; } else { - Tcl_Namespace *namespacePtr = - Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)); - /* * Private method handling. [TIP 500] * @@ -830,7 +829,9 @@ TclOO_Object_VarName( /* * The variable reference must not disappear too soon. [Bug 74b6110204] */ - TclSetVarNamespaceVar(varPtr); + if (!TclIsVarArrayElement(varPtr)) { + TclSetVarNamespaceVar(varPtr); + } /* * Now that we've pinned down what variable we're really talking about @@ -840,17 +841,23 @@ TclOO_Object_VarName( TclNewObj(varNamePtr); if (aryVar != NULL) { Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr); - + Tcl_AppendPrintfToObj(varNamePtr, "(%s)", + Tcl_GetString(VarHashGetKey(varPtr))); + } else if (!TclIsVarArrayElement(varPtr)) { + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr); + } else { /* - * WARNING! This code pokes inside the implementation of hash tables! + * Target is an element of an array but we don't know which one. + * The name in the object's namespace is the best we can do. + * [Bug 2da1cb0c80] */ - - Tcl_AppendToObj(varNamePtr, "(", -1); - Tcl_AppendObjToObj(varNamePtr, ((VarInHash *) - varPtr)->entry.key.objPtr); - Tcl_AppendToObj(varNamePtr, ")", -1); - } else { - Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr); + if (arg[0] == ':' && arg[1] == ':') { + Tcl_DecrRefCount(varNamePtr); + varNamePtr = argPtr; + } else { + Tcl_AppendPrintfToObj(varNamePtr, "%s::%s", + namespacePtr->fullName, TclGetString(argPtr)); + } } Tcl_SetObjResult(interp, varNamePtr); return TCL_OK; diff --git a/tests/oo.test b/tests/oo.test index cb449f0..502b3f7 100644 --- a/tests/oo.test +++ b/tests/oo.test @@ -3092,6 +3092,31 @@ test oo-19.4 {OO: varname ghosts [Bug 74b6110204]} -setup { } -cleanup { testClass destroy } -result {::testoo19_4::foo 0 ::testoo19_4::foo} +test oo-19.5 {OO: varname array elements [Bug 2da1cb0c80]} -setup { + set obj [oo::object new] + oo::objdefine $obj export eval varname +} -constraints knownBug -body { + $obj eval { + namespace upvar :: tcl_platform(platform) foo + } + $obj varname foo +} -cleanup { + $obj destroy +} -result ::tcl_platform(platform) +test oo-19.5.1 {OO: varname array elements before Tcl 9 [Bug 2da1cb0c80]} -setup { + oo::class create testClass { + self export createWithNamespace + export eval varname + } +} -body { + set obj [testClass createWithNamespace obj oo-19.5.1] + $obj eval { + namespace upvar :: tcl_platform(platform) foo + } + $obj varname foo +} -cleanup { + testClass destroy +} -result ::oo-19.5.1::foo test oo-20.1 {OO: variable method} -body { oo::class create testClass { |