diff options
| -rw-r--r-- | ChangeLog | 5 | ||||
| -rw-r--r-- | generic/tclVar.c | 152 |
2 files changed, 102 insertions, 55 deletions
@@ -1,3 +1,8 @@ +2007-10-27 Miguel Sofer <msofer@users.sf.net> + + * generic/tclVar.c: try to preserve Tcl_Objs when doing variable + lookups by name, partially addressing [Bug 1793601] + 2007-10-27 Donal K. Fellows <dkf@users.sf.net> * tools/tcltk-man2html.tcl (make-man-pages, htmlize-text) diff --git a/generic/tclVar.c b/generic/tclVar.c index 5b1a580..db3d090 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -16,7 +16,7 @@ * 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.152 2007/09/08 23:36:55 msofer Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.153 2007/10/27 00:24:17 msofer Exp $ */ #include "tclInt.h" @@ -148,6 +148,8 @@ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr); static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr, Var *varPtr, int flags); +static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp, Tcl_Obj *namePtr, + Tcl_Namespace *contextNsPtr, int flags); static int ObjMakeUpvar(Tcl_Interp *interp, CallFrame *framePtr, Tcl_Obj *otherP1Ptr, const char *otherP2, const int otherFlags, @@ -504,43 +506,10 @@ TclObjLookupVarEx( char *part2 = part2Ptr? TclGetString(part2Ptr):NULL; char *newPart2 = NULL; - /* - * If part1Ptr is a tclParsedVarNameType, separate it into the pre-parsed - * parts. - */ - *arrayPtrPtr = NULL; - if (typePtr == &tclParsedVarNameType) { - if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) { - if (part2Ptr != NULL) { - /* - * ERROR: part1Ptr is already an array element, cannot specify - * a part2. - */ - - if (flags & TCL_LEAVE_ERR_MSG) { - TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, - needArray, -1); - } - return NULL; - } - part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2; - if (newPart2) { - part2Ptr = Tcl_NewStringObj(newPart2, -1); - Tcl_IncrRefCount(part2Ptr); - } - part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1; - typePtr = part1Ptr->typePtr; - } - parsed = 1; - } - part1 = Tcl_GetStringFromObj(part1Ptr, &len1); if (varFramePtr) { nsPtr = varFramePtr->nsPtr; - if (nsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { - goto doParse; - } } else { /* * Some variables in the global ns have to be initialized before the @@ -548,12 +517,14 @@ TclObjLookupVarEx( */ nsPtr = NULL; - goto doParse; } if (typePtr == &localVarNameType) { - int localIndex = (int) part1Ptr->internalRep.ptrAndLongRep.value; + int localIndex; + + localVarNameTypeHandling: + localIndex = (int) part1Ptr->internalRep.ptrAndLongRep.value; if (HasLocalVars(varFramePtr) && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) && (localIndex < varFramePtr->numCompiledLocals)) { @@ -611,7 +582,40 @@ TclObjLookupVarEx( #endif } - doParse: + /* + * If part1Ptr is a tclParsedVarNameType, separate it into the pre-parsed + * parts. + */ + + if (typePtr == &tclParsedVarNameType) { + if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) { + if (part2Ptr != NULL) { + /* + * ERROR: part1Ptr is already an array element, cannot specify + * a part2. + */ + + if (flags & TCL_LEAVE_ERR_MSG) { + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, + needArray, -1); + } + return NULL; + } + part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2; + if (newPart2) { + part2Ptr = Tcl_NewStringObj(newPart2, -1); + Tcl_IncrRefCount(part2Ptr); + } + part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1; + typePtr = part1Ptr->typePtr; + if (typePtr == &localVarNameType) { + goto localVarNameTypeHandling; + } + } + parsed = 1; + } + part1 = Tcl_GetStringFromObj(part1Ptr, &len1); + if (!parsed && (*(part1 + len1 - 1) == ')')) { /* * part1Ptr is possibly an unparsed array element. @@ -778,7 +782,7 @@ TclObjLookupVarEx( * (Bug #835020) */ -#define LOOKUP_FOR_UPVAR 0x40000 +#define AVOID_RESOLVERS 0x40000 /* *---------------------------------------------------------------------- @@ -828,7 +832,7 @@ TclLookupSimpleVar( Tcl_Obj *varNamePtr, /* This is a simple variable name that could * represent a scalar or an array. */ int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, - * LOOKUP_FOR_UPVAR and TCL_LEAVE_ERR_MSG bits + * AVOID_RESOLVERS 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 @@ -869,7 +873,7 @@ TclLookupSimpleVar( */ if ((cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) - && !(flags & LOOKUP_FOR_UPVAR)) { + && !(flags & AVOID_RESOLVERS)) { resPtr = iPtr->resolverPtr; if (cxtNsPtr->varResProc) { result = (*cxtNsPtr->varResProc)(interp, varName, @@ -921,11 +925,10 @@ TclLookupSimpleVar( || ((*varName == ':') && (*(varName+1) == ':')); if (lookGlobal) { *indexPtr = -1; - flags = (flags | TCL_GLOBAL_ONLY) & - ~(TCL_NAMESPACE_ONLY | LOOKUP_FOR_UPVAR); + flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY; } else { - if (flags & LOOKUP_FOR_UPVAR) { - flags = (flags | TCL_NAMESPACE_ONLY) & ~LOOKUP_FOR_UPVAR; + if (flags & AVOID_RESOLVERS) { + flags = (flags | TCL_NAMESPACE_ONLY); } if (flags & TCL_NAMESPACE_ONLY) { *indexPtr = -2; @@ -937,9 +940,8 @@ TclLookupSimpleVar( * otherwise generate our own error! */ - varPtr = (Var *) Tcl_FindNamespaceVar(interp, varName, - (Tcl_Namespace *) cxtNsPtr, flags & ~TCL_LEAVE_ERR_MSG); - + varPtr = (Var *) ObjFindNamespaceVar(interp, varNamePtr, + (Tcl_Namespace *) cxtNsPtr, (flags | AVOID_RESOLVERS) & ~TCL_LEAVE_ERR_MSG); if (varPtr == NULL) { Tcl_Obj *tailPtr; @@ -3562,7 +3564,7 @@ TclPtrObjMakeUpvar( /* * Lookup and eventually create the new variable. Set the flag bit - * LOOKUP_FOR_UPVAR to indicate the special resolution rules for upvar + * AVOID_RESOLVERS 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. @@ -3570,7 +3572,7 @@ TclPtrObjMakeUpvar( */ varPtr = TclLookupSimpleVar(interp, myNamePtr, - (myFlags|LOOKUP_FOR_UPVAR), /* create */ 1, &errMsg, &index); + (myFlags|AVOID_RESOLVERS), /* create */ 1, &errMsg, &index); if (varPtr == NULL) { TclObjVarErrMsg(interp, myNamePtr, NULL, "create", errMsg, -1); return TCL_ERROR; @@ -4841,7 +4843,38 @@ Tcl_FindNamespaceVar( * Otherwise, points to namespace in which to * resolve name. If NULL, look up name in the * current namespace. */ - int flags) /* An OR'd combination of flags: + int flags) /* An OR'd combination of: AVOID_RESOLVERS, + * TCL_GLOBAL_ONLY (look up name only in + * global namespace), TCL_NAMESPACE_ONLY (look + * up only in contextNsPtr, or the current + * namespace if contextNsPtr is NULL), and + * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY + * and TCL_NAMESPACE_ONLY are given, + * TCL_GLOBAL_ONLY is ignored. */ +{ + Tcl_Obj *namePtr = Tcl_NewStringObj(name, -1); + Tcl_Var var; + + Tcl_IncrRefCount(namePtr); + var = ObjFindNamespaceVar(interp, namePtr, contextNsPtr, flags); + Tcl_DecrRefCount(namePtr); + return var; +} + +static Tcl_Var +ObjFindNamespaceVar( + Tcl_Interp *interp, /* The interpreter in which to find the + * variable. */ + Tcl_Obj *namePtr, /* Variable's name. If it starts with "::", + * will be looked up in global namespace. + * Else, looked up first in contextNsPtr + * (current namespace if contextNsPtr is + * NULL), then in global namespace. */ + Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag set. + * Otherwise, points to namespace in which to + * resolve name. If NULL, look up name in the + * current namespace. */ + int flags) /* An OR'd combination of: AVOID_RESOLVERS, * TCL_GLOBAL_ONLY (look up name only in * global namespace), TCL_NAMESPACE_ONLY (look * up only in contextNsPtr, or the current @@ -4859,7 +4892,8 @@ Tcl_FindNamespaceVar( int result; Tcl_Var var; Tcl_Obj *simpleNamePtr; - + char *name = TclGetString(namePtr); + /* * 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 @@ -4874,7 +4908,8 @@ Tcl_FindNamespaceVar( cxtNsPtr = (Namespace *) TclGetCurrentNamespace(interp); } - if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { + if (!(flags & AVOID_RESOLVERS) && + (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL)) { resPtr = iPtr->resolverPtr; if (cxtNsPtr->varResProc) { @@ -4913,14 +4948,21 @@ Tcl_FindNamespaceVar( */ varPtr = NULL; - simpleNamePtr = Tcl_NewStringObj(simpleName, -1); - Tcl_IncrRefCount(simpleNamePtr); + if (simpleName != name) { + simpleNamePtr = Tcl_NewStringObj(simpleName, -1); + Tcl_IncrRefCount(simpleNamePtr); + } else { + simpleNamePtr = namePtr; + } + for (search = 0; (search < 2) && (varPtr == NULL); search++) { if ((nsPtr[search] != NULL) && (simpleName != NULL)) { varPtr = VarHashFindVar(&nsPtr[search]->varTable, simpleNamePtr); } } - Tcl_DecrRefCount(simpleNamePtr); + if (simpleName != name) { + Tcl_DecrRefCount(simpleNamePtr); + } if (varPtr != NULL) { return (Tcl_Var) varPtr; } else if (flags & TCL_LEAVE_ERR_MSG) { |