An imperfect fix for [2da1cb0c80] given that can't do the right thing

tcltk · Aug 7, 2024 · 6a67eff · 6a67eff
2 parents 7224f3e + afda19b
commit 6a67eff
Show file tree

Hide file tree

Showing 2 changed files with 45 additions and 13 deletions.
diff --git 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
@@ -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 {