diff options
| -rw-r--r-- | ChangeLog | 5 | ||||
| -rw-r--r-- | generic/tclOOBasic.c | 27 | ||||
| -rw-r--r-- | tests/oo.test | 13 |
3 files changed, 42 insertions, 3 deletions
@@ -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 { |