From 208ca31442c2e1c40f81bd060a735acadfdce4d3 Mon Sep 17 00:00:00 2001 From: Miguel Sofer Date: Mon, 24 Mar 2003 00:55:15 +0000 Subject: * generic/tclVar.c: * tests/var.test: fixing ObjMakeUpvar's lookup algorithm for the created local variable, bugs #631741 and #696893. --- ChangeLog | 7 +++++++ generic/tclVar.c | 60 +++++++++++++++++++++++++++++++++++++++----------------- tests/var.test | 12 +++++++++++- 3 files changed, 60 insertions(+), 19 deletions(-) diff --git a/ChangeLog b/ChangeLog index a32a280..12fbcc3 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2003-03-24 Miguel Sofer + + * 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-22 Kevin Kenny * library/dde/pkgIndex.tcl: 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; diff --git a/tests/var.test b/tests/var.test index 93b44f2..c8e57d8 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.20.2.1 2003/03/24 00:55:16 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} { -- cgit v0.12