Let [$obj varname x(y)] work. [Bug 2883857]

3 files changed, 42 insertions, 3 deletions

diff --git a/ChangeLog b/ChangeLog
index f5e6f58..42b3dd3 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2009-10-22  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclOOBasic.c (TclOO_Object_VarName): [Bug 2883857]: Allow
+	the passing of array element names through this method.
+
 2009-10-21  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclPosixStr.c: [Bug 2882561]: Work around oddity on Haiku OS
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index f70d4f9..f6e4542 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -9,7 +9,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclOOBasic.c,v 1.18 2009/03/24 10:46:04 dkf Exp $
+ * RCS: @(#) $Id: tclOOBasic.c,v 1.19 2009/10/22 15:39:58 dkf Exp $
  */
 
 #ifdef HAVE_CONFIG_H
@@ -608,7 +608,30 @@ TclOO_Object_VarName(
     }
 
     varNamePtr = Tcl_NewObj();
-    Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
+    if (aryVar != NULL) {
+	Tcl_HashEntry *hPtr;
+	Tcl_HashSearch search;
+
+	Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr);
+
+	/*
+	 * WARNING! This code pokes inside the implementation of hash tables!
+	 */
+
+	hPtr = Tcl_FirstHashEntry((Tcl_HashTable *) aryVar->value.tablePtr,
+		&search);
+	while (hPtr != NULL) {
+	    if (varPtr == Tcl_GetHashValue(hPtr)) {
+		Tcl_AppendToObj(varNamePtr, "(", -1);
+		Tcl_AppendObjToObj(varNamePtr, hPtr->key.objPtr);
+		Tcl_AppendToObj(varNamePtr, ")", -1);
+		break;
+	    }
+	    hPtr = Tcl_NextHashEntry(&search);
+	}
+    } else {
+	Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
+    }
     Tcl_SetObjResult(interp, varNamePtr);
     return TCL_OK;
 }
diff --git a/tests/oo.test b/tests/oo.test
index 829c8ce..a976a7d 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -7,7 +7,7 @@
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: oo.test,v 1.29 2009/06/24 15:29:40 dkf Exp $
+# RCS: @(#) $Id: oo.test,v 1.30 2009/10/22 15:39:58 dkf Exp $
 
 package require TclOO 0.6.1 ;# Must match value in generic/tclOO.h
 if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -1626,6 +1626,17 @@ test oo-19.1 {OO: varname method} -setup {
     inst destroy
     rename foo {}
 } -result {{x {} write} ok ok 0}
+test oo-19.2 {OO: varname method: Bug 2883857} -setup {
+    oo::class create SpecialClass
+    oo::objdefine SpecialClass export createWithNamespace
+    SpecialClass createWithNamespace inst ::oo_test
+    oo::objdefine inst export varname eval
+} -body {
+    inst eval { variable x; array set x {y z} }
+    inst varname x(y)
+} -cleanup {
+    SpecialClass destroy
+} -result ::oo_test::x(y)
 
 test oo-20.1 {OO: variable method} -body {
     oo::class create testClass {