* generic/tclVar.c:

	* tests/var.test: fixing ObjMakeUpvar's lookup algorithm for the
	created local variable, bugs #631741 and #696893.

3 files changed, 60 insertions, 19 deletions

diff --git a/ChangeLog b/ChangeLog
index b11fbd4..35366a1 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2003-03-24  Miguel Sofer <msofer@users.sf.net>
+
+	* generic/tclVar.c:
+	* tests/var.test: fixing ObjMakeUpvar's lookup algorithm for the
+	created local variable, bugs #631741 (Chris Darroch) and #696893
+	(David Hilker). 
+	
 2003-03-24  Pat Thoyts  <patthoyts@users.sourceforge.net>
 
 	* library/dde/pkgIndex.tcl: bumped version to 1.2.2 in tclWinDde.c,
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 11868fd..65dad51 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -15,12 +15,13 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclVar.c,v 1.69 2002/11/12 02:23:03 hobbs Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.70 2003/03/24 00:49:00 msofer Exp $
  */
 
 #include "tclInt.h"
 #include "tclPort.h"
 
+
 /*
  * The strings below are used to indicate what went wrong when a
  * variable access is denied.
@@ -55,7 +56,7 @@ static void		DisposeTraceResult _ANSI_ARGS_((int flags,
 static int              ObjMakeUpvar _ANSI_ARGS_((Tcl_Interp *interp, 
                             CallFrame *framePtr, Tcl_Obj *otherP1Ptr, 
                             CONST char *otherP2, CONST int otherFlags,
-		            CONST char *myName, CONST int myFlags, int index));
+		            CONST char *myName, int myFlags, int index));
 static Var *		NewVar _ANSI_ARGS_((void));
 static ArraySearch *	ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
 			    CONST Var *varPtr, CONST char *varName,
@@ -596,6 +597,16 @@ TclObjLookupVar(interp, part1Ptr, part2, flags, msg, createPart1, createPart2,
 }
 
 /*
+ * This flag bit should not interfere with TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
+ * or TCL_LEAVE_ERR_MSG; it signals that the variable lookup is performed for 
+ * upvar (or similar) purposes, with slightly different rules:
+ *   - Bug #696893 - variable is either proc-local or in the current
+ *     namespace; never follow the second (global) resolution path 
+ *   - Bug #631741 - do not use special namespace or interp resolvers
+ */
+#define LOOKUP_FOR_UPVAR 0x400
+
+/*
  *----------------------------------------------------------------------
  *
  * TclLookupSimpleVar --
@@ -642,7 +653,8 @@ TclLookupSimpleVar(interp, varName, flags, create, errMsgPtr, indexPtr)
     CONST char *varName;        /* This is a simple variable name that could
 				 * representa scalar or an array. */
     int flags;		        /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
-				 * and TCL_LEAVE_ERR_MSG bits matter. */
+				 * LOOKUP_FOR_UPVAR and TCL_LEAVE_ERR_MSG bits 
+				 * matter. */
     CONST int create;		/* If 1, create hash table entry for varname,
 				 * if it doesn't already exist. If 0, return 
 				 * error if it doesn't exist. */
@@ -669,19 +681,21 @@ TclLookupSimpleVar(interp, varName, flags, create, errMsgPtr, indexPtr)
     varNsPtr = NULL;		/* set non-NULL if a nonlocal variable */
     *indexPtr = -3;
 
+    if ((flags & TCL_GLOBAL_ONLY) || iPtr->varFramePtr == NULL) {
+        cxtNsPtr = iPtr->globalNsPtr;
+    } else {
+        cxtNsPtr = iPtr->varFramePtr->nsPtr;
+    }
+
     /*
      * If this namespace has a variable resolver, then give it first
      * crack at the variable resolution.  It may return a Tcl_Var
      * value, it may signal to continue onward, or it may signal
      * an error.
      */
-    if ((flags & TCL_GLOBAL_ONLY) || iPtr->varFramePtr == NULL) {
-        cxtNsPtr = iPtr->globalNsPtr;
-    } else {
-        cxtNsPtr = iPtr->varFramePtr->nsPtr;
-    }
 
-    if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
+    if ((cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) 
+	    && !(flags & LOOKUP_FOR_UPVAR)) {
         resPtr = iPtr->resolverPtr;
 
         if (cxtNsPtr->varResProc) {
@@ -736,10 +750,15 @@ TclLookupSimpleVar(interp, varName, flags, create, errMsgPtr, indexPtr)
 	    || ((*varName == ':') && (*(varName+1) == ':'));
 	if (lookGlobal) {
 	    *indexPtr = -1;
-	    flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY;
-	} else if (flags & TCL_NAMESPACE_ONLY) {
-	    *indexPtr = -2;
-	}
+	    flags = (flags | TCL_GLOBAL_ONLY) & ~(TCL_NAMESPACE_ONLY|LOOKUP_FOR_UPVAR);
+	} else {
+	    if (flags & LOOKUP_FOR_UPVAR) {
+		flags = (flags | TCL_NAMESPACE_ONLY) & ~LOOKUP_FOR_UPVAR;
+	    }
+	    if (flags & TCL_NAMESPACE_ONLY) {
+		*indexPtr = -2;
+	    }
+	} 
 
 	/*
 	 * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable,
@@ -3458,7 +3477,7 @@ ObjMakeUpvar(interp, framePtr, otherP1Ptr, otherP2, otherFlags, myName, myFlags,
 				 * indicates scope of "other" variable. */
     CONST char *myName;		/* Name of variable which will refer to
 				 * otherP1/otherP2. Must be a scalar. */
-    CONST int myFlags;		/* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
+    int myFlags;		/* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
 				 * indicates scope of myName. */
     int index;                  /* If the variable to be linked is an indexed
 				 * scalar, this is its index. Otherwise, -1. */
@@ -3490,7 +3509,7 @@ ObjMakeUpvar(interp, framePtr, otherP1Ptr, otherP2, otherFlags, myName, myFlags,
 
     if (index >= 0) {
 	if (!varFramePtr->isProcCallFrame) {
-	    panic("ObjMakeUpVar called with an index outside from a proc.\n");
+	    panic("ObjMakeUpvar called with an index outside from a proc.\n");
 	}
 	varPtr = &(varFramePtr->compiledLocals[index]);
     } else {
@@ -3513,11 +3532,16 @@ ObjMakeUpvar(interp, framePtr, otherP1Ptr, otherP2, otherFlags, myName, myFlags,
 	}
 	
 	/*
-	 * Lookup and eventually create the new variable.
+	 * Lookup and eventually create the new variable. Set the flag bit
+	 * LOOKUP_FOR_UPVAR to indicate the special resolution rules for 
+	 * upvar purposes: 
+	 *   - Bug #696893 - variable is either proc-local or in the current
+	 *     namespace; never follow the second (global) resolution path 
+	 *   - Bug #631741 - do not use special namespace or interp resolvers
 	 */
 	
-	varPtr = TclLookupSimpleVar(interp, myName, myFlags, /*create*/ 1, 
-				    &errMsg, &index);
+	varPtr = TclLookupSimpleVar(interp, myName, (myFlags | LOOKUP_FOR_UPVAR), 
+	        /* create */ 1, &errMsg, &index);
 	if (varPtr == NULL) {
 	    VarErrMsg(interp, myName, NULL, "create", errMsg);
 	    return TCL_ERROR;
diff --git a/tests/var.test b/tests/var.test
index 93b44f2..7fff348 100644
--- a/tests/var.test
+++ b/tests/var.test
@@ -14,7 +14,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: var.test,v 1.20 2002/10/17 17:41:45 dgp Exp $
+# RCS: @(#) $Id: var.test,v 1.21 2003/03/24 00:49:00 msofer Exp $
 #
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -262,6 +262,16 @@ test var-3.9 {MakeUpvar, my var has invalid ns name} {
     set aaaaa 789789
     list [catch {upvar #0 aaaaa test_ns_fred::lnk} msg] $msg
 } {1 {can't create "test_ns_fred::lnk": parent namespace doesn't exist}}
+test var-3.10 {MakeUpvar, } {
+    namespace eval {} {
+	set bar 0
+	namespace eval foo upvar bar bar
+	set foo::bar 1
+	catch {list $bar $foo::bar} msg
+	unset ::aaaaa
+	set msg
+    }
+} {1 1}
 
 if {[info commands testgetvarfullname] != {}} {
     test var-4.1 {Tcl_GetVariableName, global variable} {