[Bug 3603695]: Change the way that the [oo::object] 'varname' method is

implemented so that there are no longer problems with interactions due to the
resolver. Thanks to Taylor Venable <tcvena@gmail.com> for identifying the
problem.

3 files changed, 53 insertions, 28 deletions

diff --git a/ChangeLog b/ChangeLog
index 3047cc6..743c571 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2013-02-09  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclOOBasic.c (TclOO_Object_VarName): [Bug 3603695]: Change
+	the way that the 'varname' method is implemented so that there are no
+	longer problems with interactions due to the resolver. Thanks to
+	Taylor Venable <tcvena@gmail.com> for identifying the problem.
+
 2013-02-08  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/regc_nfa.c (duptraverse): [Bug 3603557]: Increase the
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 0676618..f8cd1a4 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -687,52 +687,51 @@ TclOO_Object_VarName(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const *objv)	/* The actual arguments. */
 {
-    Interp *iPtr = (Interp *) interp;
     Var *varPtr, *aryVar;
-    Tcl_Obj *varNamePtr;
+    Tcl_Obj *varNamePtr, *argPtr;
+    const char *arg;
 
     if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
 	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
 		"varName");
 	return TCL_ERROR;
     }
+    argPtr = objv[objc-1];
+    arg = Tcl_GetString(argPtr);
 
     /*
-     * Switch to the object's namespace for the duration of this call. Like
-     * this, the variable is looked up in the namespace of the object, and not
-     * in the namespace of the caller. Otherwise this would only work if the
-     * caller was a method of the object itself, which might not be true if
-     * the method was exported. This is a bit of a hack, but the simplest way
-     * to do this (pushing a stack frame would be horribly expensive by
-     * comparison, and is only done when we'd otherwise interfere with the
-     * global namespace).
+     * Convert the variable name to fully-qualified form if it wasn't already.
+     * This has to be done prior to lookup because we can run into problems
+     * with resolvers otherwise. [Bug 3603695]
+     *
+     * We still need to do the lookup; the variable could be linked to another
+     * variable and we want the target's name.
      */
 
-    if (iPtr->varFramePtr == NULL) {
-	Tcl_CallFrame *dummyFrame;
-
-	TclPushStackFrame(interp, &dummyFrame,
-		Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)),0);
-	varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,
-		TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);
-	TclPopStackFrame(interp);
+    if (arg[0] == ':' && arg[1] == ':') {
+	varNamePtr = argPtr;
     } else {
-	Namespace *savedNsPtr;
-
-	savedNsPtr = iPtr->varFramePtr->nsPtr;
-	iPtr->varFramePtr->nsPtr = (Namespace *)
+	Tcl_Namespace *namespacePtr =
 		Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
-	varPtr = TclObjLookupVar(interp, objv[objc-1], NULL,
-		TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to",1,1,&aryVar);
-	iPtr->varFramePtr->nsPtr = savedNsPtr;
-    }
 
+	varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
+	Tcl_AppendToObj(varNamePtr, "::", 2);
+	Tcl_AppendObjToObj(varNamePtr, argPtr);
+    }
+    Tcl_IncrRefCount(varNamePtr);
+    varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
+	    TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar);
+    Tcl_DecrRefCount(varNamePtr);
     if (varPtr == NULL) {
-	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE",
-		TclGetString(objv[objc-1]), NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, NULL);
 	return TCL_ERROR;
     }
 
+    /*
+     * Now that we've pinned down what variable we're really talking about
+     * (including traversing variable links), convert back to a name.
+     */
+
     varNamePtr = Tcl_NewObj();
     if (aryVar != NULL) {
 	Tcl_HashEntry *hPtr;
diff --git a/tests/oo.test b/tests/oo.test
index 5d34077..49fe150 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -2204,6 +2204,25 @@ test oo-19.2 {OO: varname method: Bug 2883857} -setup {
 } -cleanup {
     SpecialClass destroy
 } -result ::oo_test::x(y)
+test oo-19.3 {OO: varname method and variable decl: Bug 3603695} -setup {
+    oo::class create testClass {
+	variable foo
+	export varname
+	constructor {} {
+	    variable foo x
+	}
+	method bar {obj} {
+	    my varname foo
+	    $obj varname foo
+	}
+    }
+} -body {
+    testClass create A
+    testClass create B
+    lsearch [list [A varname foo] [B varname foo]] [B bar A]
+} -cleanup {
+    testClass destroy
+} -result 0
 
 test oo-20.1 {OO: variable method} -body {
     oo::class create testClass {