summaryrefslogtreecommitdiffstats
path: root/generic/tclVar.c
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2003-03-24 00:55:15 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2003-03-24 00:55:15 (GMT)
commit208ca31442c2e1c40f81bd060a735acadfdce4d3 (patch)
treed9b1ebf48b0822af1a572cf09b012c8974fe9c46 /generic/tclVar.c
parent11faa6f4300fd411354704845136e378832cdb24 (diff)
downloadtcl-208ca31442c2e1c40f81bd060a735acadfdce4d3.zip
tcl-208ca31442c2e1c40f81bd060a735acadfdce4d3.tar.gz
tcl-208ca31442c2e1c40f81bd060a735acadfdce4d3.tar.bz2
* generic/tclVar.c:
* tests/var.test: fixing ObjMakeUpvar's lookup algorithm for the created local variable, bugs #631741 and #696893.
Diffstat (limited to 'generic/tclVar.c')
-rw-r--r--generic/tclVar.c60
1 files changed, 42 insertions, 18 deletions
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 11868fd..d3778c6 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.69.2.1 2003/03/24 00:55:16 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;