summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2009-10-22 15:39:58 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2009-10-22 15:39:58 (GMT)
commita14cd9979de8b9856c979aae40f3c8889b2d8d9b (patch)
treea045c04ec4a4410e0f5a548ea98550340520b1af
parent0fca0c346fbe4fb05578bffffc93048a9e0db914 (diff)
downloadtcl-a14cd9979de8b9856c979aae40f3c8889b2d8d9b.zip
tcl-a14cd9979de8b9856c979aae40f3c8889b2d8d9b.tar.gz
tcl-a14cd9979de8b9856c979aae40f3c8889b2d8d9b.tar.bz2
Let [$obj varname x(y)] work. [Bug 2883857]
-rw-r--r--ChangeLog5
-rw-r--r--generic/tclOOBasic.c27
-rw-r--r--tests/oo.test13
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 {