Fix [Bug 2712377]: [info vars] and object declared variables

4 files changed, 127 insertions, 5 deletions

diff --git a/ChangeLog b/ChangeLog
index 4c961d0..d66e5b7 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2012-04-09  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclVar.c (AppendLocals): [Bug 2712377]: Fix problem with
+	reporting of declared variables in methods. It's really a problem with
+	how [info vars] interacts with variable resolvers; this is just a bit
+	of a hack so it is no longer a big problem.
+
 2012-04-04  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclOO.c (Tcl_NewObjectInstance, TclNRNewObjectInstance):
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 1d1276d..d5cc6e1 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -1780,7 +1780,6 @@ FinalizeAlloc(
     Object *oPtr = data[1];
     Tcl_InterpState state = data[2];
     Tcl_Object *objectPtr = data[3];
-    //int flags = oPtr->flags;
 
     /*
      * It's an error if the object was whacked in the constructor. Force this
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 1bf4abc..e92dc5f 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -18,6 +18,7 @@
  */
 
 #include "tclInt.h"
+#include "tclOOInt.h"
 
 /*
  * Prototypes for the variable hash key methods.
@@ -6083,7 +6084,7 @@ TclInfoVarsCmd(
 		}
 	    }
 	}
-    } else if (((Interp *)interp)->varFramePtr->procPtr != NULL) {
+    } else if (iPtr->varFramePtr->procPtr != NULL) {
 	AppendLocals(interp, listPtr, simplePatternPtr, 1);
     }
 
@@ -6269,17 +6270,21 @@ AppendLocals(
 {
     Interp *iPtr = (Interp *) interp;
     Var *varPtr;
-    int i, localVarCt;
+    int i, localVarCt, added;
     Tcl_Obj **varNamePtr, *objNamePtr;
     const char *varName;
     TclVarHashTable *localVarTablePtr;
     Tcl_HashSearch search;
+    Tcl_HashTable addedTable;
     const char *pattern = patternPtr? TclGetString(patternPtr) : NULL;
 
     localVarCt = iPtr->varFramePtr->numCompiledLocals;
     varPtr = iPtr->varFramePtr->compiledLocals;
     localVarTablePtr = iPtr->varFramePtr->varTablePtr;
     varNamePtr = &iPtr->varFramePtr->localCachePtr->varName0;
+    if (includeLinks) {
+	Tcl_InitObjHashTable(&addedTable);
+    }
 
     for (i = 0; i < localVarCt; i++, varNamePtr++) {
 	/*
@@ -6291,6 +6296,9 @@ AppendLocals(
 	    varName = TclGetString(*varNamePtr);
 	    if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
 		Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr);
+		if (includeLinks) {
+		    Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added);
+		}
 	    }
 	}
 	varPtr++;
@@ -6301,7 +6309,7 @@ AppendLocals(
      */
 
     if (localVarTablePtr == NULL) {
-	return;
+	goto objectVars;
     }
 
     /*
@@ -6315,9 +6323,13 @@ AppendLocals(
 		    && (includeLinks || !TclIsVarLink(varPtr))) {
 		Tcl_ListObjAppendElement(interp, listPtr,
 			VarHashGetKey(varPtr));
+		if (includeLinks) {
+		    Tcl_CreateHashEntry(&addedTable, VarHashGetKey(varPtr),
+			    &added);
+		}
 	    }
 	}
-	return;
+	goto objectVars;
     }
 
     /*
@@ -6333,9 +6345,41 @@ AppendLocals(
 	    varName = TclGetString(objNamePtr);
 	    if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
 		Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
+		if (includeLinks) {
+		    Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
+		}
+	    }
+	}
+    }
+
+  objectVars:
+    if (!includeLinks) {
+	return;
+    }
+
+    if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) {
+	CallContext *contextPtr = iPtr->varFramePtr->clientData;
+	Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
+
+	if (mPtr->declaringObjectPtr) {
+	    FOREACH(objNamePtr, mPtr->declaringObjectPtr->variables) {
+		Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
+		if (added && (!pattern ||
+			Tcl_StringMatch(TclGetString(objNamePtr), pattern))) {
+		    Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
+		}
+	    }
+	} else {
+	    FOREACH(objNamePtr, mPtr->declaringClassPtr->variables) {
+		Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
+		if (added && (!pattern ||
+			Tcl_StringMatch(TclGetString(objNamePtr), pattern))) {
+		    Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
+		}
 	    }
 	}
     }
+    Tcl_DeleteHashTable(&addedTable);
 }
 
 /*
diff --git a/tests/oo.test b/tests/oo.test
index 8c5aeb3..a0e7345 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -2946,6 +2946,78 @@ test oo-27.18 {variables declaration - multiple use} -setup {
     foo create bar
     list [bar boo] [bar boo]
 } -returnCodes error -match glob -result {unknown method "-?": must be *}
+test oo-27.19 {variables declaration and [info vars]: Bug 2712377} -setup {
+    oo::class create Foo
+    set result {}
+} -body {
+    # This is really a test of problems to do with Tcl's introspection when a
+    # variable resolver is present...
+    oo::define Foo {
+	variable foo bar
+	method setvars {f b} {
+	    set foo $f
+	    set bar $b
+	}
+	method dump1 {} {
+	    lappend ::result <1>
+	    foreach v [lsort [info vars *]] {
+		lappend ::result $v=[set $v]
+	    }
+	    lappend ::result [info locals] [info locals *]
+	}
+	method dump2 {} {
+	    lappend ::result <2>
+	    foreach v [lsort [info vars *]] {
+		lappend ::result $v=[set $v]
+	    }
+	    lappend ::result | foo=$foo [info locals] [info locals *]
+	}
+    }
+
+    Foo create stuff
+    stuff setvars what ever
+    stuff dump1
+    stuff dump2
+    return $result
+} -cleanup {
+    Foo destroy
+} -result {<1> bar=ever foo=what v v <2> bar=ever foo=what | foo=what v v}
+test oo-27.20 {variables declaration and [info vars]: Bug 2712377} -setup {
+    oo::class create Foo
+    set result {}
+} -body {
+    # This is really a test of problems to do with Tcl's introspection when a
+    # variable resolver is present...
+    oo::define Foo {
+	variable foo bar
+	method setvars {f b} {
+	    set foo $f
+	    set bar $b
+	}
+	method dump1 {} {
+	    lappend ::result <1>
+	    foreach v [lsort [info vars *o]] {
+		lappend ::result $v=[set $v]
+	    }
+	    lappend ::result [info locals] [info locals *]
+	}
+	method dump2 {} {
+	    lappend ::result <2>
+	    foreach v [lsort [info vars *o]] {
+		lappend ::result $v=[set $v]
+	    }
+	    lappend ::result | foo=$foo [info locals] [info locals *]
+	}
+    }
+
+    Foo create stuff
+    stuff setvars what ever
+    stuff dump1
+    stuff dump2
+    return $result
+} -cleanup {
+    Foo destroy
+} -result {<1> foo=what v v <2> foo=what | foo=what v v}
 
 # A feature that's not supported because the mechanism may change without
 # warning, but is supposed to work...