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

2 files changed, 46 insertions, 8 deletions

diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 13749b2..0397474 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -686,12 +686,14 @@ TclOO_Object_VarName(
     Var *varPtr, *aryVar;
     Tcl_Obj *varNamePtr, *argPtr;
     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 = Tcl_GetString(argPtr);
 
@@ -707,9 +709,6 @@ TclOO_Object_VarName(
     if (arg[0] == ':' && arg[1] == ':') {
 	varNamePtr = argPtr;
     } else {
-	Tcl_Namespace *namespacePtr =
-		Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
-
 	varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
 	Tcl_AppendToObj(varNamePtr, "::", 2);
 	Tcl_AppendObjToObj(varNamePtr, argPtr);
@@ -726,7 +725,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
@@ -748,15 +749,27 @@ TclOO_Object_VarName(
 		&search);
 	while (hPtr != NULL) {
 	    if (varPtr == Tcl_GetHashValue(hPtr)) {
-		Tcl_AppendToObj(varNamePtr, "(", -1);
-		Tcl_AppendObjToObj(varNamePtr, hPtr->key.objPtr);
-		Tcl_AppendToObj(varNamePtr, ")", -1);
+		Tcl_AppendPrintfToObj(varNamePtr, "(%s)",
+			TclGetString(hPtr->key.objPtr));
 		break;
 	    }
 	    hPtr = Tcl_NextHashEntry(&search);
 	}
-    } else {
+    } else if (!TclIsVarArrayElement(varPtr)) {
 	Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
+    } else {
+	/*
+	 * 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]
+	 */
+	if (arg[0] == ':' && arg[1] == ':') {
+	    Tcl_DecrRefCount(varNamePtr);
+	    varNamePtr = argPtr;
+	} else {
+	    Tcl_AppendPrintfToObj(varNamePtr, "%s::%s",
+		    namespacePtr->fullName, arg);
+	}
     }
     Tcl_SetObjResult(interp, varNamePtr);
     return TCL_OK;
diff --git a/tests/oo.test b/tests/oo.test
index 6bf9c70..cc25007 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -2947,6 +2947,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 {