diff options
Diffstat (limited to 'tcl/generic/tclVar.c')
| -rw-r--r-- | tcl/generic/tclVar.c | 3482 |
1 files changed, 1913 insertions, 1569 deletions
diff --git a/tcl/generic/tclVar.c b/tcl/generic/tclVar.c index fce00ab6138..3bbbcc3ac25 100644 --- a/tcl/generic/tclVar.c +++ b/tcl/generic/tclVar.c @@ -10,6 +10,7 @@ * Copyright (c) 1987-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -25,46 +26,130 @@ * variable access is denied. */ -static char *noSuchVar = "no such variable"; -static char *isArray = "variable is array"; -static char *needArray = "variable isn't array"; -static char *noSuchElement = "no such element in array"; -static char *danglingElement = "upvar refers to element in deleted array"; -static char *danglingVar = "upvar refers to variable in deleted namespace"; -static char *badNamespace = "parent namespace doesn't exist"; -static char *missingName = "missing variable name"; -static char *isArrayElement = "name refers to an element in an array"; +static CONST char *noSuchVar = "no such variable"; +static CONST char *isArray = "variable is array"; +static CONST char *needArray = "variable isn't array"; +static CONST char *noSuchElement = "no such element in array"; +static CONST char *danglingElement = + "upvar refers to element in deleted array"; +static CONST char *danglingVar = + "upvar refers to variable in deleted namespace"; +static CONST char *badNamespace = "parent namespace doesn't exist"; +static CONST char *missingName = "missing variable name"; +static CONST char *isArrayElement = "name refers to an element in an array"; /* * Forward references to procedures defined later in this file: */ -static char * CallTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr, - Var *varPtr, char *part1, char *part2, - int flags)); +static int CallVarTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr, + Var *varPtr, CONST char *part1, CONST char *part2, + int flags, CONST int leaveErrMsg)); static void CleanupVar _ANSI_ARGS_((Var *varPtr, Var *arrayPtr)); static void DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr)); static void DeleteArray _ANSI_ARGS_((Interp *iPtr, - char *arrayName, Var *varPtr, int flags)); -static int MakeUpvar _ANSI_ARGS_(( - Interp *iPtr, CallFrame *framePtr, - char *otherP1, char *otherP2, int otherFlags, - char *myName, int myFlags)); + CONST char *arrayName, Var *varPtr, int flags)); +static void DisposeTraceResult _ANSI_ARGS_((int flags, + char *result)); +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)); static Var * NewVar _ANSI_ARGS_((void)); static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp, - Var *varPtr, char *varName, char *string)); + CONST Var *varPtr, CONST char *varName, + Tcl_Obj *handleObj)); static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp, - char *part1, char *part2, char *operation, - char *reason)); + CONST char *part1, CONST char *part2, + CONST char *operation, CONST char *reason)); +static int SetArraySearchObj _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); + + +/* + * Functions defined in this file that may be exported in the future + * for use by the bytecode compiler and engine or to the public interface. + */ + +Var * TclLookupSimpleVar _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *varName, int flags, CONST int create, + CONST char **errMsgPtr, int *indexPtr)); +int TclObjUnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *part1Ptr, CONST char *part2, int flags)); + +static Tcl_FreeInternalRepProc FreeLocalVarName; +static Tcl_DupInternalRepProc DupLocalVarName; +static Tcl_UpdateStringProc UpdateLocalVarName; +static Tcl_FreeInternalRepProc FreeNsVarName; +static Tcl_DupInternalRepProc DupNsVarName; +static Tcl_FreeInternalRepProc FreeParsedVarName; +static Tcl_DupInternalRepProc DupParsedVarName; +static Tcl_UpdateStringProc UpdateParsedVarName; + +/* + * Types of Tcl_Objs used to cache variable lookups. + * + * + * localVarName - INTERNALREP DEFINITION: + * twoPtrValue.ptr1 = pointer to the corresponding Proc + * twoPtrValue.ptr2 = index into locals table + * + * nsVarName - INTERNALREP DEFINITION: + * twoPtrValue.ptr1: pointer to the namespace containing the + * reference + * twoPtrValue.ptr2: pointer to the corresponding Var + * + * parsedVarName - INTERNALREP DEFINITION: + * twoPtrValue.ptr1 = pointer to the array name Tcl_Obj, + * or NULL if it is a scalar variable + * twoPtrValue.ptr2 = pointer to the element name string + * (owned by this Tcl_Obj), or NULL if + * it is a scalar variable + */ + +Tcl_ObjType tclLocalVarNameType = { + "localVarName", + FreeLocalVarName, DupLocalVarName, UpdateLocalVarName, NULL +}; + +Tcl_ObjType tclNsVarNameType = { + "namespaceVarName", + FreeNsVarName, DupNsVarName, NULL, NULL +}; + +Tcl_ObjType tclParsedVarNameType = { + "parsedVarName", + FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, NULL +}; + +/* + * Type of Tcl_Objs used to speed up array searches. + * + * INTERNALREP DEFINITION: + * twoPtrValue.ptr1 = searchIdNumber as offset from (char*)NULL + * twoPtrValue.ptr2 = variableNameStartInString as offset from (char*)NULL + * + * Note that the value stored in ptr2 is the offset into the string of + * the start of the variable name and not the address of the variable + * name itself, as this can be safely copied. + */ +Tcl_ObjType tclArraySearchType = { + "array search", + NULL, NULL, NULL, SetArraySearchObj +}; + /* *---------------------------------------------------------------------- * * TclLookupVar -- * - * This procedure is used by virtually all of the variable code to - * locate a variable given its name(s). + * This procedure is used to locate a variable given its name(s). It + * has been mostly superseded by TclObjLookupVar, it is now only used + * by the string-based interfaces. It is kept in tcl8.4 mainly because + * it is in the internal stubs table, so that some extension may be + * calling it. * * Results: * The return value is a pointer to the variable structure indicated by @@ -93,19 +178,18 @@ static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp, * *---------------------------------------------------------------------- */ - Var * TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, arrayPtrPtr) Tcl_Interp *interp; /* Interpreter to use for lookup. */ - register char *part1; /* If part2 isn't NULL, this is the name of + CONST char *part1; /* If part2 isn't NULL, this is the name of * an array. Otherwise, this * is a full variable name that could * include a parenthesized array element. */ - char *part2; /* Name of element within array, or NULL. */ + CONST char *part2; /* Name of element within array, or NULL. */ int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * and TCL_LEAVE_ERR_MSG bits matter. */ - char *msg; /* Verb to use in error messages, e.g. + CONST char *msg; /* Verb to use in error messages, e.g. * "read" or "set". Only needed if * TCL_LEAVE_ERR_MSG is set in flags. */ int createPart1; /* If 1, create hash table entry for part 1 @@ -119,35 +203,24 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, * address of array variable. Otherwise * this is set to NULL. */ { - Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; - /* Points to the procedure call frame whose - * variables are currently in use. Same as - * the current procedure's frame, if any, - * unless an "uplevel" is executing. */ - Tcl_HashTable *tablePtr; /* Points to the hashtable, if any, in which - * to look up the variable. */ - Tcl_Var var; /* Used to search for global names. */ - Var *varPtr; /* Points to the Var structure returned for - * the variable. */ - char *elName; /* Name of array element or NULL; may be + Var *varPtr; + CONST char *elName; /* Name of array element or NULL; may be * same as part2, or may be openParen+1. */ - char *openParen, *closeParen; + int openParen, closeParen; /* If this procedure parses a name into - * array and index, these point to the - * parens around the index. Otherwise they - * are NULL. These are needed to restore - * the parens after parsing the name. */ - Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr; - ResolverScheme *resPtr; - Tcl_HashEntry *hPtr; - register char *p; - int new, i, result; + * array and index, these are the offsets to + * the parens around the index. Otherwise + * they are -1. */ + register CONST char *p; + CONST char *errMsg = NULL; + int index; +#define VAR_NAME_BUF_SIZE 26 + char buffer[VAR_NAME_BUF_SIZE]; + char *newVarName = buffer; varPtr = NULL; *arrayPtrPtr = NULL; - openParen = closeParen = NULL; - varNsPtr = NULL; /* set non-NULL if a nonlocal variable */ + openParen = closeParen = -1; /* * Parse part1 into array name and index. @@ -162,28 +235,439 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, elName = part2; for (p = part1; *p ; p++) { if (*p == '(') { - openParen = p; + openParen = p - part1; do { p++; } while (*p != '\0'); p--; if (*p == ')') { if (part2 != NULL) { - openParen = NULL; if (flags & TCL_LEAVE_ERR_MSG) { VarErrMsg(interp, part1, part2, msg, needArray); } - goto done; + return NULL; } - closeParen = p; - *openParen = 0; - elName = openParen+1; + closeParen = p - part1; } else { - openParen = NULL; + openParen = -1; } break; } } + if (openParen != -1) { + if (closeParen >= VAR_NAME_BUF_SIZE) { + newVarName = ckalloc((unsigned int) (closeParen+1)); + } + memcpy(newVarName, part1, (unsigned int) closeParen); + newVarName[openParen] = '\0'; + newVarName[closeParen] = '\0'; + part1 = newVarName; + elName = newVarName + openParen + 1; + } + + varPtr = TclLookupSimpleVar(interp, part1, flags, + createPart1, &errMsg, &index); + if (varPtr == NULL) { + if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) { + VarErrMsg(interp, part1, elName, msg, errMsg); + } + } else { + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + if (elName != NULL) { + *arrayPtrPtr = varPtr; + varPtr = TclLookupArrayElement(interp, part1, elName, flags, + msg, createPart1, createPart2, varPtr); + } + } + if (newVarName != buffer) { + ckfree(newVarName); + } + + return varPtr; + +#undef VAR_NAME_BUF_SIZE +} + +/* + *---------------------------------------------------------------------- + * + * TclObjLookupVar -- + * + * This procedure is used by virtually all of the variable code to + * locate a variable given its name(s). The parsing into array/element + * components and (if possible) the lookup results are cached in + * part1Ptr, which is converted to one of the varNameTypes. + * + * Results: + * The return value is a pointer to the variable structure indicated by + * part1Ptr and part2, or NULL if the variable couldn't be found. If + * the variable is found, *arrayPtrPtr is filled with the address of the + * variable structure for the array that contains the variable (or NULL + * if the variable is a scalar). If the variable can't be found and + * either createPart1 or createPart2 are 1, a new as-yet-undefined + * (VAR_UNDEFINED) variable structure is created, entered into a hash + * table, and returned. + * + * If the variable isn't found and creation wasn't specified, or some + * other error occurs, NULL is returned and an error message is left in + * the interp's result if TCL_LEAVE_ERR_MSG is set in flags. + * + * Note: it's possible for the variable returned to be VAR_UNDEFINED + * even if createPart1 or createPart2 are 1 (these only cause the hash + * table entry or array to be created). For example, the variable might + * be a global that has been unset but is still referenced by a + * procedure, or a variable that has been unset but it only being kept + * in existence (if VAR_UNDEFINED) by a trace. + * + * Side effects: + * New hashtable entries may be created if createPart1 or createPart2 + * are 1. + * The object part1Ptr is converted to one of tclLocalVarNameType, + * tclNsVarNameType or tclParsedVarNameType and caches as much of the + * lookup as it can. + * + *---------------------------------------------------------------------- + */ +Var * +TclObjLookupVar(interp, part1Ptr, part2, flags, msg, createPart1, createPart2, + arrayPtrPtr) + Tcl_Interp *interp; /* Interpreter to use for lookup. */ + register Tcl_Obj *part1Ptr; /* If part2 isn't NULL, this is the name + * of an array. Otherwise, this is a full + * variable name that could include a parenthesized + * array element. */ + CONST char *part2; /* Name of element within array, or NULL. */ + int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * and TCL_LEAVE_ERR_MSG bits matter. */ + CONST char *msg; /* Verb to use in error messages, e.g. + * "read" or "set". Only needed if + * TCL_LEAVE_ERR_MSG is set in flags. */ + CONST int createPart1; /* If 1, create hash table entry for part 1 + * of name, if it doesn't already exist. If + * 0, return error if it doesn't exist. */ + CONST int createPart2; /* If 1, create hash table entry for part 2 + * of name, if it doesn't already exist. If + * 0, return error if it doesn't exist. */ + Var **arrayPtrPtr; /* If the name refers to an element of an + * array, *arrayPtrPtr gets filled in with + * address of array variable. Otherwise + * this is set to NULL. */ +{ + Interp *iPtr = (Interp *) interp; + register Var *varPtr; /* Points to the variable's in-frame Var + * structure. */ + char *part1; + int index, len1, len2; + int parsed = 0; + Tcl_Obj *objPtr; + Tcl_ObjType *typePtr = part1Ptr->typePtr; + CONST char *errMsg = NULL; + CallFrame *varFramePtr = iPtr->varFramePtr; + Namespace *nsPtr; + + /* + * If part1Ptr is a tclParsedVarNameType, separate it into the + * pre-parsed parts. + */ + + *arrayPtrPtr = NULL; + if (typePtr == &tclParsedVarNameType) { + if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) { + if (part2 != NULL) { + /* + * ERROR: part1Ptr is already an array element, cannot + * specify a part2. + */ + + if (flags & TCL_LEAVE_ERR_MSG) { + part1 = TclGetString(part1Ptr); + VarErrMsg(interp, part1, part2, msg, needArray); + } + return NULL; + } + part2 = (char *) part1Ptr->internalRep.twoPtrValue.ptr2; + part1Ptr = (Tcl_Obj *) part1Ptr->internalRep.twoPtrValue.ptr1; + typePtr = part1Ptr->typePtr; + } + parsed = 1; + } + part1 = Tcl_GetStringFromObj(part1Ptr, &len1); + + nsPtr = ((varFramePtr == NULL)? iPtr->globalNsPtr : varFramePtr->nsPtr); + if (nsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { + goto doParse; + } + + if (typePtr == &tclLocalVarNameType) { + Proc *procPtr = (Proc *) part1Ptr->internalRep.twoPtrValue.ptr1; + int localIndex = (int) part1Ptr->internalRep.twoPtrValue.ptr2; + int useLocal; + + useLocal = ((varFramePtr != NULL) && varFramePtr->isProcCallFrame + && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))); + if (useLocal && (procPtr == varFramePtr->procPtr)) { + /* + * part1Ptr points to an indexed local variable of the + * correct procedure: use the cached value. + */ + + varPtr = &(varFramePtr->compiledLocals[localIndex]); + goto donePart1; + } + goto doneParsing; + } else if (typePtr == &tclNsVarNameType) { + Namespace *cachedNsPtr; + int useGlobal, useReference; + + varPtr = (Var *) part1Ptr->internalRep.twoPtrValue.ptr2; + cachedNsPtr = (Namespace *) part1Ptr->internalRep.twoPtrValue.ptr1; + useGlobal = (cachedNsPtr == iPtr->globalNsPtr) + && ((flags & TCL_GLOBAL_ONLY) + || ((*part1 == ':') && (*(part1+1) == ':')) + || (varFramePtr == NULL) + || (!varFramePtr->isProcCallFrame + && (nsPtr == iPtr->globalNsPtr))); + useReference = useGlobal || ((cachedNsPtr == nsPtr) + && ((flags & TCL_NAMESPACE_ONLY) + || (varFramePtr && !varFramePtr->isProcCallFrame + && !(flags & TCL_GLOBAL_ONLY) + /* careful: an undefined ns variable could + * be hiding a valid global reference. */ + && !(varPtr->flags & VAR_UNDEFINED)))); + if (useReference && (varPtr->hPtr != NULL)) { + /* + * A straight global or namespace reference, use it. It isn't + * so simple to deal with 'implicit' namespace references, i.e., + * those where the reference could be to either a namespace + * or a global variable. Those we lookup again. + * + * If (varPtr->hPtr == NULL), this might be a reference to a + * variable in a deleted namespace, kept alive by e.g. part1Ptr. + * We could conceivably be so unlucky that a new namespace was + * created at the same address as the deleted one, so to be + * safe we test for a valid hPtr. + */ + goto donePart1; + } + goto doneParsing; + } + + doParse: + if (!parsed && (*(part1 + len1 - 1) == ')')) { + /* + * part1Ptr is possibly an unparsed array element. + */ + register int i; + char *newPart2; + len2 = -1; + for (i = 0; i < len1; i++) { + if (*(part1 + i) == '(') { + if (part2 != NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + VarErrMsg(interp, part1, part2, msg, needArray); + } + } + + /* + * part1Ptr points to an array element; first copy + * the element name to a new string part2. + */ + + part2 = part1 + i + 1; + len2 = len1 - i - 2; + len1 = i; + + newPart2 = ckalloc((unsigned int) (len2+1)); + memcpy(newPart2, part2, (unsigned int) len2); + *(newPart2+len2) = '\0'; + part2 = newPart2; + + /* + * Free the internal rep of the original part1Ptr, now + * renamed objPtr, and set it to tclParsedVarNameType. + */ + + objPtr = part1Ptr; + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + typePtr->freeIntRepProc(objPtr); + } + objPtr->typePtr = &tclParsedVarNameType; + + /* + * Define a new string object to hold the new part1Ptr, i.e., + * the array name. Set the internal rep of objPtr, reset + * typePtr and part1 to contain the references to the + * array name. + */ + + part1Ptr = Tcl_NewStringObj(part1, len1); + Tcl_IncrRefCount(part1Ptr); + + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) part1Ptr; + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) part2; + + typePtr = part1Ptr->typePtr; + part1 = TclGetString(part1Ptr); + break; + } + } + } + + doneParsing: + /* + * part1Ptr is not an array element; look it up, and convert + * it to one of the cached types if possible. + */ + + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { + typePtr->freeIntRepProc(part1Ptr); + part1Ptr->typePtr = NULL; + } + + varPtr = TclLookupSimpleVar(interp, part1, flags, + createPart1, &errMsg, &index); + if (varPtr == NULL) { + if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) { + VarErrMsg(interp, part1, part2, msg, errMsg); + } + return NULL; + } + + /* + * Cache the newly found variable if possible. + */ + + if (index >= 0) { + /* + * An indexed local variable. + */ + + Proc *procPtr = ((Interp *) interp)->varFramePtr->procPtr; + + part1Ptr->typePtr = &tclLocalVarNameType; + procPtr->refCount++; + part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr; + part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) index; + } else if (index > -3) { + Namespace *nsPtr; + + nsPtr = ((index == -1)? iPtr->globalNsPtr : varFramePtr->nsPtr); + varPtr->refCount++; + part1Ptr->typePtr = &tclNsVarNameType; + part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr; + part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr; + } else { + /* + * At least mark part1Ptr as already parsed. + */ + part1Ptr->typePtr = &tclParsedVarNameType; + part1Ptr->internalRep.twoPtrValue.ptr1 = NULL; + part1Ptr->internalRep.twoPtrValue.ptr2 = NULL; + } + + donePart1: +#if 0 + if (varPtr == NULL) { + if (flags & TCL_LEAVE_ERR_MSG) { + part1 = TclGetString(part1Ptr); + VarErrMsg(interp, part1, part2, msg, + "Cached variable reference is NULL."); + } + return NULL; + } +#endif + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + + if (part2 != NULL) { + /* + * Array element sought: look it up. + */ + + part1 = TclGetString(part1Ptr); + *arrayPtrPtr = varPtr; + varPtr = TclLookupArrayElement(interp, part1, part2, + flags, msg, createPart1, createPart2, varPtr); + } + return varPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclLookupSimpleVar -- + * + * This procedure is used by to locate a simple variable (i.e., not + * an array element) given its name. + * + * Results: + * The return value is a pointer to the variable structure indicated by + * varName, or NULL if the variable couldn't be found. If the variable + * can't be found and create is 1, a new as-yet-undefined (VAR_UNDEFINED) + * variable structure is created, entered into a hash table, and returned. + * + * If the current CallFrame corresponds to a proc and the variable found is + * one of the compiledLocals, its index is placed in *indexPtr. Otherwise, + * *indexPtr will be set to (according to the needs of TclObjLookupVar): + * -1 a global reference + * -2 a reference to a namespace variable + * -3 a non-cachable reference, i.e., one of: + * . non-indexed local var + * . a reference of unknown origin; + * . resolution by a namespace or interp resolver + * + * If the variable isn't found and creation wasn't specified, or some + * other error occurs, NULL is returned and the corresponding error + * message is left in *errMsgPtr. + * + * Note: it's possible for the variable returned to be VAR_UNDEFINED + * even if create is 1 (this only causes the hash table entry to be + * created). For example, the variable might be a global that has been + * unset but is still referenced by a procedure, or a variable that has + * been unset but it only being kept in existence (if VAR_UNDEFINED) by + * a trace. + * + * Side effects: + * A new hashtable entry may be created if create is 1. + * + *---------------------------------------------------------------------- + */ + +Var * +TclLookupSimpleVar(interp, varName, flags, create, errMsgPtr, indexPtr) + Tcl_Interp *interp; /* Interpreter to use for lookup. */ + 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. */ + 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. */ + CONST char **errMsgPtr; + int *indexPtr; +{ + Interp *iPtr = (Interp *) interp; + CallFrame *varFramePtr = iPtr->varFramePtr; + /* Points to the procedure call frame whose + * variables are currently in use. Same as + * the current procedure's frame, if any, + * unless an "uplevel" is executing. */ + Tcl_HashTable *tablePtr; /* Points to the hashtable, if any, in which + * to look up the variable. */ + Tcl_Var var; /* Used to search for global names. */ + Var *varPtr; /* Points to the Var structure returned for + * the variable. */ + Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr; + ResolverScheme *resPtr; + Tcl_HashEntry *hPtr; + int new, i, result; + + varPtr = NULL; + varNsPtr = NULL; /* set non-NULL if a nonlocal variable */ + *indexPtr = -3; /* * If this namespace has a variable resolver, then give it first @@ -191,7 +675,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, * value, it may signal to continue onward, or it may signal * an error. */ - if ((flags & TCL_GLOBAL_ONLY) != 0 || iPtr->varFramePtr == NULL) { + if ((flags & TCL_GLOBAL_ONLY) || iPtr->varFramePtr == NULL) { cxtNsPtr = iPtr->globalNsPtr; } else { cxtNsPtr = iPtr->varFramePtr->nsPtr; @@ -201,7 +685,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, resPtr = iPtr->resolverPtr; if (cxtNsPtr->varResProc) { - result = (*cxtNsPtr->varResProc)(interp, part1, + result = (*cxtNsPtr->varResProc)(interp, varName, (Tcl_Namespace *) cxtNsPtr, flags, &var); } else { result = TCL_CONTINUE; @@ -209,7 +693,7 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, while (result == TCL_CONTINUE && resPtr) { if (resPtr->varResProc) { - result = (*resPtr->varResProc)(interp, part1, + result = (*resPtr->varResProc)(interp, varName, (Tcl_Namespace *) cxtNsPtr, flags, &var); } resPtr = resPtr->nextPtr; @@ -217,71 +701,85 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, if (result == TCL_OK) { varPtr = (Var *) var; - goto lookupVarPart2; + return varPtr; } else if (result != TCL_CONTINUE) { - return (Var *) NULL; + return NULL; } } /* - * Look up part1. Look it up as either a namespace variable or as a + * Look up varName. Look it up as either a namespace variable or as a * local variable in a procedure call frame (varFramePtr). - * Interpret part1 as a namespace variable if: + * Interpret varName as a namespace variable if: * 1) so requested by a TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY flag, * 2) there is no active frame (we're at the global :: scope), * 3) the active frame was pushed to define the namespace context * for a "namespace eval" or "namespace inscope" command, * 4) the name has namespace qualifiers ("::"s). - * Otherwise, if part1 is a local variable, search first in the + * Otherwise, if varName is a local variable, search first in the * frame's array of compiler-allocated local variables, then in its * hashtable for runtime-created local variables. * - * If createPart1 and the variable isn't found, create the variable and, + * If create and the variable isn't found, create the variable and, * if necessary, create varFramePtr's local var hashtable. */ if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0) || (varFramePtr == NULL) || !varFramePtr->isProcCallFrame - || (strstr(part1, "::") != NULL)) { - char *tail; + || (strstr(varName, "::") != NULL)) { + CONST char *tail; + int lookGlobal; + lookGlobal = (flags & TCL_GLOBAL_ONLY) + || (cxtNsPtr == iPtr->globalNsPtr) + || ((*varName == ':') && (*(varName+1) == ':')); + if (lookGlobal) { + *indexPtr = -1; + flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY; + } else if (flags & TCL_NAMESPACE_ONLY) { + *indexPtr = -2; + } + /* * Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable, * or otherwise generate our own error! */ - var = Tcl_FindNamespaceVar(interp, part1, (Tcl_Namespace *) NULL, + var = Tcl_FindNamespaceVar(interp, varName, (Tcl_Namespace *) cxtNsPtr, flags & ~TCL_LEAVE_ERR_MSG); if (var != (Tcl_Var) NULL) { varPtr = (Var *) var; } if (varPtr == NULL) { - if (createPart1) { /* var wasn't found so create it */ - TclGetNamespaceForQualName(interp, part1, (Namespace *) NULL, + if (create) { /* var wasn't found so create it */ + TclGetNamespaceForQualName(interp, varName, cxtNsPtr, flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); - if (varNsPtr == NULL) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, badNamespace); - } - goto done; + *errMsgPtr = badNamespace; + return NULL; } if (tail == NULL) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, missingName); - } - goto done; + *errMsgPtr = missingName; + return NULL; } hPtr = Tcl_CreateHashEntry(&varNsPtr->varTable, tail, &new); varPtr = NewVar(); Tcl_SetHashValue(hPtr, varPtr); varPtr->hPtr = hPtr; varPtr->nsPtr = varNsPtr; - } else { /* var wasn't found and not to create it */ - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, noSuchVar); + if ((lookGlobal) || (varNsPtr == NULL)) { + /* + * The variable was created starting from the global + * namespace: a global reference is returned even if + * it wasn't explicitly requested. + */ + *indexPtr = -1; + } else { + *indexPtr = -2; } - goto done; + } else { /* var wasn't found and not to create it */ + *errMsgPtr = noSuchVar; + return NULL; } } } else { /* local var: look in frame varFramePtr */ @@ -289,156 +787,170 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, int localCt = procPtr->numCompiledLocals; CompiledLocal *localPtr = procPtr->firstLocalPtr; Var *localVarPtr = varFramePtr->compiledLocals; - int part1Len = strlen(part1); + int varNameLen = strlen(varName); for (i = 0; i < localCt; i++) { if (!TclIsVarTemporary(localPtr)) { register char *localName = localVarPtr->name; - if ((part1[0] == localName[0]) - && (part1Len == localPtr->nameLength) - && (strcmp(part1, localName) == 0)) { - varPtr = localVarPtr; - break; + if ((varName[0] == localName[0]) + && (varNameLen == localPtr->nameLength) + && (strcmp(varName, localName) == 0)) { + *indexPtr = i; + return localVarPtr; } } localVarPtr++; localPtr = localPtr->nextPtr; } - if (varPtr == NULL) { /* look in the frame's var hash table */ - tablePtr = varFramePtr->varTablePtr; - if (createPart1) { - if (tablePtr == NULL) { - tablePtr = (Tcl_HashTable *) - ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS); - varFramePtr->varTablePtr = tablePtr; - } - hPtr = Tcl_CreateHashEntry(tablePtr, part1, &new); - if (new) { - varPtr = NewVar(); - Tcl_SetHashValue(hPtr, varPtr); - varPtr->hPtr = hPtr; - varPtr->nsPtr = NULL; /* a local variable */ - } else { - varPtr = (Var *) Tcl_GetHashValue(hPtr); - } + tablePtr = varFramePtr->varTablePtr; + if (create) { + if (tablePtr == NULL) { + tablePtr = (Tcl_HashTable *) + ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS); + varFramePtr->varTablePtr = tablePtr; + } + hPtr = Tcl_CreateHashEntry(tablePtr, varName, &new); + if (new) { + varPtr = NewVar(); + Tcl_SetHashValue(hPtr, varPtr); + varPtr->hPtr = hPtr; + varPtr->nsPtr = NULL; /* a local variable */ } else { - hPtr = NULL; - if (tablePtr != NULL) { - hPtr = Tcl_FindHashEntry(tablePtr, part1); - } - if (hPtr == NULL) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, noSuchVar); - } - goto done; - } varPtr = (Var *) Tcl_GetHashValue(hPtr); } + } else { + hPtr = NULL; + if (tablePtr != NULL) { + hPtr = Tcl_FindHashEntry(tablePtr, varName); + } + if (hPtr == NULL) { + *errMsgPtr = noSuchVar; + return NULL; + } + varPtr = (Var *) Tcl_GetHashValue(hPtr); } } + return varPtr; +} + +/* + *---------------------------------------------------------------------- + * + * TclLookupArrayElement -- + * + * This procedure is used to locate a variable which is in an array's + * hashtable given a pointer to the array's Var structure and the + * element's name. + * + * Results: + * The return value is a pointer to the variable structure , or NULL if + * the variable couldn't be found. + * + * If arrayPtr points to a variable that isn't an array and createPart1 + * is 1, the corresponding variable will be converted to an array. + * Otherwise, NULL is returned and an error message is left in + * the interp's result if TCL_LEAVE_ERR_MSG is set in flags. + * + * If the variable is not found and createPart2 is 1, the variable is + * created. Otherwise, NULL is returned and an error message is left in + * the interp's result if TCL_LEAVE_ERR_MSG is set in flags. + * + * Note: it's possible for the variable returned to be VAR_UNDEFINED + * even if createPart1 or createPart2 are 1 (these only cause the hash + * table entry or array to be created). For example, the variable might + * be a global that has been unset but is still referenced by a + * procedure, or a variable that has been unset but it only being kept + * in existence (if VAR_UNDEFINED) by a trace. + * + * Side effects: + * The variable at arrayPtr may be converted to be an array if + * createPart1 is 1. A new hashtable entry may be created if createPart2 + * is 1. + * + *---------------------------------------------------------------------- + */ - lookupVarPart2: - if (openParen != NULL) { - *openParen = '('; - openParen = NULL; - } - - /* - * If varPtr is a link variable, we have a reference to some variable - * that was created through an "upvar" or "global" command. Traverse - * through any links until we find the referenced variable. - */ - - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - - /* - * If we're not dealing with an array element, return varPtr. - */ - - if (elName == NULL) { - goto done; - } +Var * +TclLookupArrayElement(interp, arrayName, elName, flags, msg, createArray, createElem, arrayPtr) + Tcl_Interp *interp; /* Interpreter to use for lookup. */ + CONST char *arrayName; /* This is the name of the array. */ + CONST char *elName; /* Name of element within array. */ + CONST int flags; /* Only TCL_LEAVE_ERR_MSG bit matters. */ + CONST char *msg; /* Verb to use in error messages, e.g. + * "read" or "set". Only needed if + * TCL_LEAVE_ERR_MSG is set in flags. */ + CONST int createArray; /* If 1, transform arrayName to be an array + * if it isn't one yet and the transformation + * is possible. If 0, return error if it + * isn't already an array. */ + CONST int createElem; /* If 1, create hash table entry for the + * element, if it doesn't already exist. If + * 0, return error if it doesn't exist. */ + Var *arrayPtr; /* Pointer to the array's Var structure. */ +{ + Tcl_HashEntry *hPtr; + int new; + Var *varPtr; /* * We're dealing with an array element. Make sure the variable is an * array and look up the element (create the element if desired). */ - if (TclIsVarUndefined(varPtr) && !TclIsVarArrayElement(varPtr)) { - if (!createPart1) { + if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) { + if (!createArray) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, noSuchVar); + VarErrMsg(interp, arrayName, elName, msg, noSuchVar); } - varPtr = NULL; - goto done; + return NULL; } /* * Make sure we are not resurrecting a namespace variable from a * deleted namespace! */ - if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { + if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, danglingVar); + VarErrMsg(interp, arrayName, elName, msg, danglingVar); } - varPtr = NULL; - goto done; + return NULL; } - TclSetVarArray(varPtr); - TclClearVarUndefined(varPtr); - varPtr->value.tablePtr = + TclSetVarArray(arrayPtr); + TclClearVarUndefined(arrayPtr); + arrayPtr->value.tablePtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); - } else if (!TclIsVarArray(varPtr)) { + Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS); + } else if (!TclIsVarArray(arrayPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, needArray); + VarErrMsg(interp, arrayName, elName, msg, needArray); } - varPtr = NULL; - goto done; - } - *arrayPtrPtr = varPtr; - if (closeParen != NULL) { - *closeParen = 0; + return NULL; } - if (createPart2) { - hPtr = Tcl_CreateHashEntry(varPtr->value.tablePtr, elName, &new); - if (closeParen != NULL) { - *closeParen = ')'; - } + + if (createElem) { + hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elName, &new); if (new) { - if (varPtr->searchPtr != NULL) { - DeleteSearches(varPtr); + if (arrayPtr->searchPtr != NULL) { + DeleteSearches(arrayPtr); } varPtr = NewVar(); Tcl_SetHashValue(hPtr, varPtr); varPtr->hPtr = hPtr; - varPtr->nsPtr = varNsPtr; + varPtr->nsPtr = arrayPtr->nsPtr; TclSetVarArrayElement(varPtr); } } else { - hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, elName); - if (closeParen != NULL) { - *closeParen = ')'; - } + hPtr = Tcl_FindHashEntry(arrayPtr->value.tablePtr, elName); if (hPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, msg, noSuchElement); + VarErrMsg(interp, arrayName, elName, msg, noSuchElement); } - varPtr = NULL; - goto done; + return NULL; } } - varPtr = (Var *) Tcl_GetHashValue(hPtr); - - done: - if (openParen != NULL) { - *openParen = '('; - } - return varPtr; + return (Var *) Tcl_GetHashValue(hPtr); } /* @@ -463,11 +975,11 @@ TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2, *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_GetVar(interp, varName, flags) Tcl_Interp *interp; /* Command interpreter in which varName is * to be looked up. */ - char *varName; /* Name of a variable in interp. */ + CONST char *varName; /* Name of a variable in interp. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG * bits. */ @@ -498,13 +1010,13 @@ Tcl_GetVar(interp, varName, flags) *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_GetVar2(interp, part1, part2, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be looked up. */ - char *part1; /* Name of an array (if part2 is non-NULL) + CONST char *part1; /* Name of an array (if part2 is non-NULL) * or the name of a variable. */ - char *part2; /* If non-NULL, gives the name of an element + CONST char *part2; /* If non-NULL, gives the name of an element * in the array part1. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG @@ -518,54 +1030,6 @@ Tcl_GetVar2(interp, part1, part2, flags) } return TclGetString(objPtr); } -/* - *---------------------------------------------------------------------- - * - * Tcl_ObjGetVar2 -- - * - * Return the value of a Tcl variable as a Tcl object, given a - * two-part name consisting of array name and element within array. - * - * Results: - * The return value points to the current object value of the variable - * given by part1Ptr and part2Ptr. If the specified variable doesn't - * exist, or if there is a clash in array usage, then NULL is returned - * and a message will be left in the interpreter's result if the - * TCL_LEAVE_ERR_MSG flag is set. - * - * Side effects: - * The ref count for the returned object is _not_ incremented to - * reflect the returned reference; if you want to keep a reference to - * the object you must increment its ref count yourself. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags) - Tcl_Interp *interp; /* Command interpreter in which variable is - * to be looked up. */ - register Tcl_Obj *part1Ptr; /* Points to an object holding the name of - * an array (if part2 is non-NULL) or the - * name of a variable. */ - register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding - * the name of an element in the array - * part1Ptr. */ - int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, - * TCL_LEAVE_ERR_MSG, and - * TCL_PARSE_PART1 bits. */ -{ - char *part1, *part2; - - part1 = Tcl_GetString(part1Ptr); - if (part2Ptr != NULL) { - part2 = Tcl_GetString(part2Ptr); - } else { - part2 = NULL; - } - - return Tcl_GetVar2Ex(interp, part1, part2, flags); -} /* *---------------------------------------------------------------------- @@ -594,87 +1058,44 @@ Tcl_Obj * Tcl_GetVar2Ex(interp, part1, part2, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be looked up. */ - char *part1; /* Name of an array (if part2 is non-NULL) + CONST char *part1; /* Name of an array (if part2 is non-NULL) * or the name of a variable. */ - char *part2; /* If non-NULL, gives the name of an element + CONST char *part2; /* If non-NULL, gives the name of an element * in the array part1. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, * and TCL_LEAVE_ERR_MSG bits. */ { - Interp *iPtr = (Interp *) interp; - register Var *varPtr; - Var *arrayPtr; - char *msg; + Var *varPtr, *arrayPtr; + /* + * We need a special flag check to see if we want to create part 1, + * because commands like lappend require read traces to trigger for + * previously non-existent values. + */ varPtr = TclLookupVar(interp, part1, part2, flags, "read", - /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); + /*createPart1*/ (flags & TCL_TRACE_READS), + /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return NULL; } - /* - * Invoke any traces that have been set for the variable. - */ - - if ((varPtr->tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, - (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY)) | TCL_TRACE_READS); - if (msg != NULL) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, "read", msg); - } - goto errorReturn; - } - } - - /* - * Return the element if it's an existing scalar variable. - */ - - if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { - return varPtr->value.objPtr; - } - - if (flags & TCL_LEAVE_ERR_MSG) { - if (TclIsVarUndefined(varPtr) && (arrayPtr != NULL) - && !TclIsVarUndefined(arrayPtr)) { - msg = noSuchElement; - } else if (TclIsVarArray(varPtr)) { - msg = isArray; - } else { - msg = noSuchVar; - } - VarErrMsg(interp, part1, part2, "read", msg); - } - - /* - * An error. If the variable doesn't exist anymore and no-one's using - * it, then free up the relevant structures and hash table entries. - */ - - errorReturn: - if (TclIsVarUndefined(varPtr)) { - CleanupVar(varPtr, arrayPtr); - } - return NULL; + return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags); } /* *---------------------------------------------------------------------- * - * TclGetIndexedScalar -- + * Tcl_ObjGetVar2 -- * - * Return the Tcl object value of a local scalar variable in the active - * procedure, given its index in the procedure's array of compiler - * allocated local variables. + * Return the value of a Tcl variable as a Tcl object, given a + * two-part name consisting of array name and element within array. * * Results: * The return value points to the current object value of the variable - * given by localIndex. If the specified variable doesn't exist, or - * there is a clash in array usage, or an error occurs while executing - * variable traces, then NULL is returned and a message will be left in - * the interpreter's result if leaveErrorMsg is 1. + * given by part1Ptr and part2Ptr. If the specified variable doesn't + * exist, or if there is a clash in array usage, then NULL is returned + * and a message will be left in the interpreter's result if the + * TCL_LEAVE_ERR_MSG flag is set. * * Side effects: * The ref count for the returned object is _not_ incremented to @@ -685,109 +1106,53 @@ Tcl_GetVar2Ex(interp, part1, part2, flags) */ Tcl_Obj * -TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) +Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be looked up. */ - register int localIndex; /* Index of variable in procedure's array - * of local variables. */ - int leaveErrorMsg; /* 1 if to leave an error message in - * interpreter's result on an error. - * Otherwise no error message is left. */ + register Tcl_Obj *part1Ptr; /* Points to an object holding the name of + * an array (if part2 is non-NULL) or the + * name of a variable. */ + register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding + * the name of an element in the array + * part1Ptr. */ + int flags; /* OR-ed combination of TCL_GLOBAL_ONLY and + * TCL_LEAVE_ERR_MSG bits. */ { - Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; - /* Points to the procedure call frame whose - * variables are currently in use. Same as - * the current procedure's frame, if any, - * unless an "uplevel" is executing. */ - Var *compiledLocals = varFramePtr->compiledLocals; - register Var *varPtr; /* Points to the variable's in-frame Var - * structure. */ - char *varName; /* Name of the local variable. */ - char *msg; - -#ifdef TCL_COMPILE_DEBUG - int localCt = varFramePtr->procPtr->numCompiledLocals; + Var *varPtr, *arrayPtr; + char *part1, *part2; - if (compiledLocals == NULL) { - fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x, no compiled locals\n", - localIndex, (unsigned int) varFramePtr); - panic("TclGetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); - } - if ((localIndex < 0) || (localIndex >= localCt)) { - fprintf(stderr, "\nTclGetIndexedScalar: can't get local %i in frame 0x%x with %i locals\n", - localIndex, (unsigned int) varFramePtr, localCt); - panic("TclGetIndexedScalar: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); - } -#endif /* TCL_COMPILE_DEBUG */ + part1 = Tcl_GetString(part1Ptr); + part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr)); - varPtr = &(compiledLocals[localIndex]); - varName = varPtr->name; - - /* - * If varPtr is a link variable, we have a reference to some variable - * that was created through an "upvar" or "global" command, or we have a - * reference to a variable in an enclosing namespace. Traverse through - * any links until we find the referenced variable. - */ - - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - /* - * Invoke any traces that have been set for the variable. + * We need a special flag check to see if we want to create part 1, + * because commands like lappend require read traces to trigger for + * previously non-existent values. */ - - if (varPtr->tracePtr != NULL) { - msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, varName, NULL, - TCL_TRACE_READS); - if (msg != NULL) { - if (leaveErrorMsg) { - VarErrMsg(interp, varName, NULL, "read", msg); - } - return NULL; - } - } - - /* - * Make sure we're dealing with a scalar variable and not an array, and - * that the variable exists (isn't undefined). - */ - - if (!TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr)) { - if (leaveErrorMsg) { - if (TclIsVarArray(varPtr)) { - msg = isArray; - } else { - msg = noSuchVar; - } - VarErrMsg(interp, varName, NULL, "read", msg); - - } + varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read", + /*createPart1*/ (flags & TCL_TRACE_READS), + /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { return NULL; } - return varPtr->value.objPtr; + + return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags); } /* *---------------------------------------------------------------------- * - * TclGetElementOfIndexedArray -- + * TclPtrGetVar -- * - * Return the Tcl object value for an element in a local array - * variable. The element is named by the object elemPtr while the - * array is specified by its index in the active procedure's array - * of compiler allocated local variables. + * Return the value of a Tcl variable as a Tcl object, given the + * pointers to the variable's (and possibly containing array's) + * VAR structure. * * Results: - * The return value points to the current object value of the - * element. If the specified array or element doesn't exist, or there - * is a clash in array usage, or an error occurs while executing - * variable traces, then NULL is returned and a message will be left in - * the interpreter's result if leaveErrorMsg is 1. + * The return value points to the current object value of the variable + * given by varPtr. If the specified variable doesn't exist, or if there + * is a clash in array usage, then NULL is returned and a message will be + * left in the interpreter's result if the TCL_LEAVE_ERR_MSG flag is set. * * Side effects: * The ref count for the returned object is _not_ incremented to @@ -798,114 +1163,31 @@ TclGetIndexedScalar(interp, localIndex, leaveErrorMsg) */ Tcl_Obj * -TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) +TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be looked up. */ - int localIndex; /* Index of array variable in procedure's - * array of local variables. */ - Tcl_Obj *elemPtr; /* Points to an object holding the name of - * an element to get in the array. */ - int leaveErrorMsg; /* 1 if to leave an error message in - * the interpreter's result on an error. - * Otherwise no error message is left. */ + register Var *varPtr; /* The variable to be read.*/ + Var *arrayPtr; /* NULL for scalar variables, pointer to + * the containing array otherwise. */ + CONST char *part1; /* Name of an array (if part2 is non-NULL) + * or the name of a variable. */ + CONST char *part2; /* If non-NULL, gives the name of an element + * in the array part1. */ + CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, + * and TCL_LEAVE_ERR_MSG bits. */ { Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; - /* Points to the procedure call frame whose - * variables are currently in use. Same as - * the current procedure's frame, if any, - * unless an "uplevel" is executing. */ - Var *compiledLocals = varFramePtr->compiledLocals; - Var *arrayPtr; /* Points to the array's in-frame Var - * structure. */ - char *arrayName; /* Name of the local array. */ - Tcl_HashEntry *hPtr; - Var *varPtr = NULL; /* Points to the element's Var structure - * that we return. Initialized to avoid - * compiler warning. */ - char *elem, *msg; - int new; - -#ifdef TCL_COMPILE_DEBUG - Proc *procPtr = varFramePtr->procPtr; - int localCt = procPtr->numCompiledLocals; - - if (compiledLocals == NULL) { - fprintf(stderr, "\nTclGetElementOfIndexedArray: can't get element of local %i in frame 0x%x, no compiled locals\n", - localIndex, (unsigned int) varFramePtr); - panic("TclGetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); - } - if ((localIndex < 0) || (localIndex >= localCt)) { - fprintf(stderr, "\nTclGetIndexedScalar: can't get element of local %i in frame 0x%x with %i locals\n", - localIndex, (unsigned int) varFramePtr, localCt); - panic("TclGetElementOfIndexedArray: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); - } -#endif /* TCL_COMPILE_DEBUG */ - - elem = TclGetString(elemPtr); - arrayPtr = &(compiledLocals[localIndex]); - arrayName = arrayPtr->name; + CONST char *msg; /* - * If arrayPtr is a link variable, we have a reference to some variable - * that was created through an "upvar" or "global" command, or we have a - * reference to a variable in an enclosing namespace. Traverse through - * any links until we find the referenced variable. - */ - - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - - /* - * Make sure we're dealing with an array and that the array variable - * exists (isn't undefined). - */ - - if (!TclIsVarArray(arrayPtr) || TclIsVarUndefined(arrayPtr)) { - if (leaveErrorMsg) { - VarErrMsg(interp, arrayName, elem, "read", noSuchVar); - } - goto errorReturn; - } - - /* - * Look up the element. Note that we must create the element (but leave - * it marked undefined) if it does not already exist. This allows a - * trace to create new array elements "on the fly" that did not exist - * before. A trace is always passed a variable for the array element. If - * the trace does not define the variable, it will be deleted below (at - * errorReturn) and an error returned. - */ - - hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new); - if (new) { - if (arrayPtr->searchPtr != NULL) { - DeleteSearches(arrayPtr); - } - varPtr = NewVar(); - Tcl_SetHashValue(hPtr, varPtr); - varPtr->hPtr = hPtr; - varPtr->nsPtr = varFramePtr->nsPtr; - TclSetVarArrayElement(varPtr); - } else { - varPtr = (Var *) Tcl_GetHashValue(hPtr); - } - - /* - * Invoke any traces that have been set for the element variable. + * Invoke any traces that have been set for the variable. */ if ((varPtr->tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem, - TCL_TRACE_READS); - if (msg != NULL) { - if (leaveErrorMsg) { - VarErrMsg(interp, arrayName, elem, "read", msg); - } + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, + (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY)) + | TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { goto errorReturn; } } @@ -918,13 +1200,16 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) return varPtr->value.objPtr; } - if (leaveErrorMsg) { - if (TclIsVarArray(varPtr)) { + if (flags & TCL_LEAVE_ERR_MSG) { + if (TclIsVarUndefined(varPtr) && (arrayPtr != NULL) + && !TclIsVarUndefined(arrayPtr)) { + msg = noSuchElement; + } else if (TclIsVarArray(varPtr)) { msg = isArray; } else { msg = noSuchVar; } - VarErrMsg(interp, arrayName, elem, "read", msg); + VarErrMsg(interp, part1, part2, "read", msg); } /* @@ -933,8 +1218,8 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg) */ errorReturn: - if ((varPtr != NULL) && TclIsVarUndefined(varPtr)) { - CleanupVar(varPtr, NULL); /* the array is not in a hashtable */ + if (TclIsVarUndefined(varPtr)) { + CleanupVar(varPtr, arrayPtr); } return NULL; } @@ -1012,12 +1297,12 @@ Tcl_SetObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_SetVar(interp, varName, newValue, flags) Tcl_Interp *interp; /* Command interpreter in which varName is * to be looked up. */ - char *varName; /* Name of a variable in interp. */ - char *newValue; /* New value for varName. */ + CONST char *varName; /* Name of a variable in interp. */ + CONST char *newValue; /* New value for varName. */ int flags; /* Various flags that tell how to set value: * any of TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, @@ -1053,16 +1338,16 @@ Tcl_SetVar(interp, varName, newValue, flags) *---------------------------------------------------------------------- */ -char * +CONST char * Tcl_SetVar2(interp, part1, part2, newValue, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be looked up. */ - char *part1; /* If part2 is NULL, this is name of scalar + CONST char *part1; /* If part2 is NULL, this is name of scalar * variable. Otherwise it is the name of * an array. */ - char *part2; /* Name of an element within an array, or + CONST char *part2; /* Name of an element within an array, or * NULL. */ - char *newValue; /* New value for variable. */ + CONST char *newValue; /* New value for variable. */ int flags; /* Various flags that tell how to set value: * any of TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, @@ -1091,9 +1376,73 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) /* *---------------------------------------------------------------------- * + * Tcl_SetVar2Ex -- + * + * Given a two-part variable name, which may refer either to a scalar + * variable or an element of an array, change the value of the variable + * to a new Tcl object value. If the named scalar or array or element + * doesn't exist then create one. + * + * Results: + * Returns a pointer to the Tcl_Obj holding the new value of the + * variable. If the write operation was disallowed because an array was + * expected but not found (or vice versa), then NULL is returned; if + * the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will + * be left in the interpreter's result. Note that the returned object + * may not be the same one referenced by newValuePtr; this is because + * variable traces may modify the variable's value. + * + * Side effects: + * The value of the given variable is set. If either the array or the + * entry didn't exist then a new variable is created. + * + * The reference count is decremented for any old value of the variable + * and incremented for its new value. If the new value for the variable + * is not the same one referenced by newValuePtr (perhaps as a result + * of a variable trace), then newValuePtr's ref count is left unchanged + * by Tcl_SetVar2Ex. newValuePtr's ref count is also left unchanged if + * we are appending it as a string value: that is, if "flags" includes + * TCL_APPEND_VALUE but not TCL_LIST_ELEMENT. + * + * The reference count for the returned object is _not_ incremented: if + * you want to keep a reference to the object you must increment its + * ref count yourself. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) + Tcl_Interp *interp; /* Command interpreter in which variable is + * to be found. */ + CONST char *part1; /* Name of an array (if part2 is non-NULL) + * or the name of a variable. */ + CONST char *part2; /* If non-NULL, gives the name of an element + * in the array part1. */ + Tcl_Obj *newValuePtr; /* New value for variable. */ + int flags; /* Various flags that tell how to set value: + * any of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */ +{ + Var *varPtr, *arrayPtr; + + varPtr = TclLookupVar(interp, part1, part2, flags, "set", + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + return NULL; + } + + return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, + newValuePtr, flags); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ObjSetVar2 -- * - * This function is the same as Tcl_SetVar2Ex below, except the + * This function is the same as Tcl_SetVar2Ex above, except the * variable names are passed in Tcl object instead of strings. * * Results: @@ -1108,7 +1457,6 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags) * Side effects: * The value of the given variable is set. If either the array or the * entry didn't exist then a new variable is created. - * *---------------------------------------------------------------------- */ @@ -1127,30 +1475,33 @@ Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) int flags; /* Various flags that tell how to set value: * any of TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, - * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG, or - * TCL_PARSE_PART1. */ + * TCL_LIST_ELEMENT, or TCL_LEAVE_ERR_MSG. */ { + Var *varPtr, *arrayPtr; char *part1, *part2; - part1 = Tcl_GetString(part1Ptr); - if (part2Ptr != NULL) { - part2 = Tcl_GetString(part2Ptr); - } else { - part2 = NULL; + part1 = TclGetString(part1Ptr); + part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr)); + + varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "set", + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + return NULL; } - - return Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags); + + return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, + newValuePtr, flags); } + /* *---------------------------------------------------------------------- * - * Tcl_SetVar2Ex -- + * TclPtrSetVar -- * - * Given a two-part variable name, which may refer either to a scalar - * variable or an element of an array, change the value of the variable - * to a new Tcl object value. If the named scalar or array or element - * doesn't exist then create one. + * This function is the same as Tcl_SetVar2Ex above, except that + * it requires pointers to the variable's Var structs in addition + * to the variable names. * * Results: * Returns a pointer to the Tcl_Obj holding the new value of the @@ -1164,49 +1515,29 @@ Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags) * Side effects: * The value of the given variable is set. If either the array or the * entry didn't exist then a new variable is created. - * - * The reference count is decremented for any old value of the variable - * and incremented for its new value. If the new value for the variable - * is not the same one referenced by newValuePtr (perhaps as a result - * of a variable trace), then newValuePtr's ref count is left unchanged - * by Tcl_SetVar2Ex. newValuePtr's ref count is also left unchanged if - * we are appending it as a string value: that is, if "flags" includes - * TCL_APPEND_VALUE but not TCL_LIST_ELEMENT. - * - * The reference count for the returned object is _not_ incremented: if - * you want to keep a reference to the object you must increment its - * ref count yourself. + * *---------------------------------------------------------------------- */ Tcl_Obj * -Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) +TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags) Tcl_Interp *interp; /* Command interpreter in which variable is - * to be found. */ - char *part1; /* Name of an array (if part2 is non-NULL) + * to be looked up. */ + register Var *varPtr; + Var *arrayPtr; + CONST char *part1; /* Name of an array (if part2 is non-NULL) * or the name of a variable. */ - char *part2; /* If non-NULL, gives the name of an element + CONST char *part2; /* If non-NULL, gives the name of an element * in the array part1. */ Tcl_Obj *newValuePtr; /* New value for variable. */ - int flags; /* Various flags that tell how to set value: - * any of TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, - * TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */ + CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, + * and TCL_LEAVE_ERR_MSG bits. */ { Interp *iPtr = (Interp *) interp; - register Var *varPtr; - Var *arrayPtr; Tcl_Obj *oldValuePtr; Tcl_Obj *resultPtr = NULL; - char *bytes; - int length, result; - - varPtr = TclLookupVar(interp, part1, part2, flags, "set", - /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); - if (varPtr == NULL) { - return NULL; - } + int result; /* * If the variable is in a hashtable and its hPtr field is NULL, then we @@ -1239,12 +1570,18 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) } /* - * At this point, if we were appending, we used to call read traces: we - * treated append as a read-modify-write. However, it seemed unlikely to - * us that a real program would be interested in such reads being done - * during a set operation. + * Invoke any read traces that have been set for the variable if it + * is requested; this is only done in the core when lappending. */ + if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) { + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, + TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { + return NULL; + } + } + /* * Set the variable's new value. If appending, append the new value to * the variable, either as a list element or as a string. Also, if @@ -1281,10 +1618,9 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) * We append newValuePtr's bytes but don't change its ref count. */ - bytes = Tcl_GetStringFromObj(newValuePtr, &length); if (oldValuePtr == NULL) { - varPtr->value.objPtr = Tcl_NewStringObj(bytes, length); - Tcl_IncrRefCount(varPtr->value.objPtr); + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); } else { if (Tcl_IsShared(oldValuePtr)) { /* append to copy */ varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); @@ -1295,34 +1631,16 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) Tcl_AppendObjToObj(oldValuePtr, newValuePtr); } } - } else { - if (flags & TCL_LIST_ELEMENT) { /* set var to list element */ - int neededBytes, listFlags; - - /* - * We set the variable to the result of converting newValuePtr's - * string rep to a list element. We do not change newValuePtr's - * ref count. - */ + } else if (newValuePtr != oldValuePtr) { + /* + * In this case we are replacing the value, so we don't need to + * do more than swap the objects. + */ - if (oldValuePtr != NULL) { - Tcl_DecrRefCount(oldValuePtr); /* discard old value */ - } - bytes = Tcl_GetStringFromObj(newValuePtr, &length); - neededBytes = Tcl_ScanElement(bytes, &listFlags); - oldValuePtr = Tcl_NewObj(); - oldValuePtr->bytes = (char *) - ckalloc((unsigned) (neededBytes + 1)); - oldValuePtr->length = Tcl_ConvertElement(bytes, - oldValuePtr->bytes, listFlags); - varPtr->value.objPtr = oldValuePtr; - Tcl_IncrRefCount(varPtr->value.objPtr); - } else if (newValuePtr != oldValuePtr) { - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); /* var is another ref */ - if (oldValuePtr != NULL) { - TclDecrRefCount(oldValuePtr); /* discard old value */ - } + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); /* var is another ref */ + if (oldValuePtr != NULL) { + TclDecrRefCount(oldValuePtr); /* discard old value */ } } TclSetVarScalar(varPtr); @@ -1337,12 +1655,9 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) if ((varPtr->tracePtr != NULL) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - char *msg = CallTraces(iPtr, arrayPtr, varPtr, part1, part2, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_WRITES); - if (msg != NULL) { - if (flags & TCL_LEAVE_ERR_MSG) { - VarErrMsg(interp, part1, part2, "set", msg); - } + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) + | TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) { goto cleanup; } } @@ -1379,403 +1694,6 @@ Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags) /* *---------------------------------------------------------------------- * - * TclSetIndexedScalar -- - * - * Change the Tcl object value of a local scalar variable in the active - * procedure, given its compile-time allocated index in the procedure's - * array of local variables. - * - * Results: - * Returns a pointer to the Tcl_Obj holding the new value of the - * variable given by localIndex. If the specified variable doesn't - * exist, or there is a clash in array usage, or an error occurs while - * executing variable traces, then NULL is returned and a message will - * be left in the interpreter's result if leaveErrorMsg is 1. Note - * that the returned object may not be the same one referenced by - * newValuePtr; this is because variable traces may modify the - * variable's value. - * - * Side effects: - * The value of the given variable is set. The reference count is - * decremented for any old value of the variable and incremented for - * its new value. If as a result of a variable trace the new value for - * the variable is not the same one referenced by newValuePtr, then - * newValuePtr's ref count is left unchanged. The ref count for the - * returned object is _not_ incremented to reflect the returned - * reference; if you want to keep a reference to the object you must - * increment its ref count yourself. This procedure does not create - * new variables, but only sets those recognized at compile time. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclSetIndexedScalar(interp, localIndex, newValuePtr, leaveErrorMsg) - Tcl_Interp *interp; /* Command interpreter in which variable is - * to be found. */ - int localIndex; /* Index of variable in procedure's array - * of local variables. */ - Tcl_Obj *newValuePtr; /* New value for variable. */ - int leaveErrorMsg; /* 1 if to leave an error message in - * the interpreter's result on an error. - * Otherwise no error message is left. */ -{ - Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; - /* Points to the procedure call frame whose - * variables are currently in use. Same as - * the current procedure's frame, if any, - * unless an "uplevel" is executing. */ - Var *compiledLocals = varFramePtr->compiledLocals; - register Var *varPtr; /* Points to the variable's in-frame Var - * structure. */ - char *varName; /* Name of the local variable. */ - Tcl_Obj *oldValuePtr; - Tcl_Obj *resultPtr = NULL; - -#ifdef TCL_COMPILE_DEBUG - Proc *procPtr = varFramePtr->procPtr; - int localCt = procPtr->numCompiledLocals; - - if (compiledLocals == NULL) { - fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x, no compiled locals\n", - localIndex, (unsigned int) varFramePtr); - panic("TclSetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); - } - if ((localIndex < 0) || (localIndex >= localCt)) { - fprintf(stderr, "\nTclSetIndexedScalar: can't set local %i in frame 0x%x with %i locals\n", - localIndex, (unsigned int) varFramePtr, localCt); - panic("TclSetIndexedScalar: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); - } -#endif /* TCL_COMPILE_DEBUG */ - - varPtr = &(compiledLocals[localIndex]); - varName = varPtr->name; - - /* - * If varPtr is a link variable, we have a reference to some variable - * that was created through an "upvar" or "global" command, or we have a - * reference to a variable in an enclosing namespace. Traverse through - * any links until we find the referenced variable. - */ - - while (TclIsVarLink(varPtr)) { - varPtr = varPtr->value.linkPtr; - } - - /* - * If the variable is in a hashtable and its hPtr field is NULL, then we - * may have an upvar to an array element where the array was deleted - * or an upvar to a namespace variable whose namespace was deleted. - * Generate an error (allowing the variable to be reset would screw up - * our storage allocation and is meaningless anyway). - */ - - if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { - if (leaveErrorMsg) { - if (TclIsVarArrayElement(varPtr)) { - VarErrMsg(interp, varName, NULL, "set", danglingElement); - } else { - VarErrMsg(interp, varName, NULL, "set", danglingVar); - } - } - return NULL; - } - - /* - * It's an error to try to set an array variable itself. - */ - - if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { - if (leaveErrorMsg) { - VarErrMsg(interp, varName, NULL, "set", isArray); - } - return NULL; - } - - /* - * Set the variable's new value and discard its old value. We don't - * append with this "set" procedure so the old value isn't needed. - */ - - oldValuePtr = varPtr->value.objPtr; - if (newValuePtr != oldValuePtr) { /* set new value */ - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */ - if (oldValuePtr != NULL) { - TclDecrRefCount(oldValuePtr); /* discard old value */ - } - } - TclSetVarScalar(varPtr); - TclClearVarUndefined(varPtr); - - /* - * Invoke any write traces for the variable. - */ - - if (varPtr->tracePtr != NULL) { - char *msg = CallTraces(iPtr, /*arrayPtr*/ NULL, varPtr, - varName, (char *) NULL, TCL_TRACE_WRITES); - if (msg != NULL) { - if (leaveErrorMsg) { - VarErrMsg(interp, varName, NULL, "set", msg); - } - goto cleanup; - } - } - - /* - * Return the variable's value unless the variable was changed in some - * gross way by a trace (e.g. it was unset and then recreated as an - * array). If it was changed is a gross way, just return an empty string - * object. - */ - - if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { - return varPtr->value.objPtr; - } - - resultPtr = Tcl_NewObj(); - - /* - * If the variable doesn't exist anymore and no-one's using it, then - * free up the relevant structures and hash table entries. - */ - - cleanup: - if (TclIsVarUndefined(varPtr)) { - CleanupVar(varPtr, NULL); - } - return resultPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclSetElementOfIndexedArray -- - * - * Change the Tcl object value of an element in a local array - * variable. The element is named by the object elemPtr while the array - * is specified by its index in the active procedure's array of - * compiler allocated local variables. - * - * Results: - * Returns a pointer to the Tcl_Obj holding the new value of the - * element. If the specified array or element doesn't exist, or there - * is a clash in array usage, or an error occurs while executing - * variable traces, then NULL is returned and a message will be left in - * the interpreter's result if leaveErrorMsg is 1. Note that the - * returned object may not be the same one referenced by newValuePtr; - * this is because variable traces may modify the variable's value. - * - * Side effects: - * The value of the given array element is set. The reference count is - * decremented for any old value of the element and incremented for its - * new value. If as a result of a variable trace the new value for the - * element is not the same one referenced by newValuePtr, then - * newValuePtr's ref count is left unchanged. The ref count for the - * returned object is _not_ incremented to reflect the returned - * reference; if you want to keep a reference to the object you must - * increment its ref count yourself. This procedure will not create new - * array variables, but only sets elements of those arrays recognized - * at compile time. However, if the entry doesn't exist then a new - * variable is created. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclSetElementOfIndexedArray(interp, localIndex, elemPtr, newValuePtr, - leaveErrorMsg) - Tcl_Interp *interp; /* Command interpreter in which the array is - * to be found. */ - int localIndex; /* Index of array variable in procedure's - * array of local variables. */ - Tcl_Obj *elemPtr; /* Points to an object holding the name of - * an element to set in the array. */ - Tcl_Obj *newValuePtr; /* New value for variable. */ - int leaveErrorMsg; /* 1 if to leave an error message in - * the interpreter's result on an error. - * Otherwise no error message is left. */ -{ - Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; - /* Points to the procedure call frame whose - * variables are currently in use. Same as - * the current procedure's frame, if any, - * unless an "uplevel" is executing. */ - Var *compiledLocals = varFramePtr->compiledLocals; - Var *arrayPtr; /* Points to the array's in-frame Var - * structure. */ - char *arrayName; /* Name of the local array. */ - char *elem; - Tcl_HashEntry *hPtr; - Var *varPtr = NULL; /* Points to the element's Var structure - * that we return. */ - Tcl_Obj *resultPtr = NULL; - Tcl_Obj *oldValuePtr; - int new; - -#ifdef TCL_COMPILE_DEBUG - Proc *procPtr = varFramePtr->procPtr; - int localCt = procPtr->numCompiledLocals; - - if (compiledLocals == NULL) { - fprintf(stderr, "\nTclSetElementOfIndexedArray: can't set element of local %i in frame 0x%x, no compiled locals\n", - localIndex, (unsigned int) varFramePtr); - panic("TclSetIndexedScalar: no compiled locals in frame 0x%x", - (unsigned int) varFramePtr); - } - if ((localIndex < 0) || (localIndex >= localCt)) { - fprintf(stderr, "\nTclSetIndexedScalar: can't set elememt of local %i in frame 0x%x with %i locals\n", - localIndex, (unsigned int) varFramePtr, localCt); - panic("TclSetElementOfIndexedArray: bad local index %i in frame 0x%x", - localIndex, (unsigned int) varFramePtr); - } -#endif /* TCL_COMPILE_DEBUG */ - - elem = TclGetString(elemPtr); - arrayPtr = &(compiledLocals[localIndex]); - arrayName = arrayPtr->name; - - /* - * If arrayPtr is a link variable, we have a reference to some variable - * that was created through an "upvar" or "global" command, or we have a - * reference to a variable in an enclosing namespace. Traverse through - * any links until we find the referenced variable. - */ - - while (TclIsVarLink(arrayPtr)) { - arrayPtr = arrayPtr->value.linkPtr; - } - - /* - * If the variable is in a hashtable and its hPtr field is NULL, then we - * may have an upvar to an array element where the array was deleted - * or an upvar to a namespace variable whose namespace was deleted. - * Generate an error (allowing the variable to be reset would screw up - * our storage allocation and is meaningless anyway). - */ - - if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) { - if (leaveErrorMsg) { - if (TclIsVarArrayElement(arrayPtr)) { - VarErrMsg(interp, arrayName, elem, "set", danglingElement); - } else { - VarErrMsg(interp, arrayName, elem, "set", danglingVar); - } - } - goto errorReturn; - } - - /* - * Make sure we're dealing with an array. - */ - - if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) { - TclSetVarArray(arrayPtr); - arrayPtr->value.tablePtr = - (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS); - TclClearVarUndefined(arrayPtr); - } else if (!TclIsVarArray(arrayPtr)) { - if (leaveErrorMsg) { - VarErrMsg(interp, arrayName, elem, "set", needArray); - } - goto errorReturn; - } - - /* - * Look up the element. - */ - - hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new); - if (new) { - if (arrayPtr->searchPtr != NULL) { - DeleteSearches(arrayPtr); - } - varPtr = NewVar(); - Tcl_SetHashValue(hPtr, varPtr); - varPtr->hPtr = hPtr; - varPtr->nsPtr = varFramePtr->nsPtr; - TclSetVarArrayElement(varPtr); - } - varPtr = (Var *) Tcl_GetHashValue(hPtr); - - /* - * It's an error to try to set an array variable itself. - */ - - if (TclIsVarArray(varPtr)) { - if (leaveErrorMsg) { - VarErrMsg(interp, arrayName, elem, "set", isArray); - } - goto errorReturn; - } - - /* - * Set the variable's new value and discard the old one. We don't - * append with this "set" procedure so the old value isn't needed. - */ - - oldValuePtr = varPtr->value.objPtr; - if (newValuePtr != oldValuePtr) { /* set new value */ - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); /* var is another ref to obj */ - if (oldValuePtr != NULL) { - TclDecrRefCount(oldValuePtr); /* discard old value */ - } - } - TclSetVarScalar(varPtr); - TclClearVarUndefined(varPtr); - - /* - * Invoke any write traces for the element variable. - */ - - if ((varPtr->tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - char *msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem, - TCL_TRACE_WRITES); - if (msg != NULL) { - if (leaveErrorMsg) { - VarErrMsg(interp, arrayName, elem, "set", msg); - } - goto errorReturn; - } - } - - /* - * Return the element's value unless it was changed in some gross way by - * a trace (e.g. it was unset and then recreated as an array). If it was - * changed is a gross way, just return an empty string object. - */ - - if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)) { - return varPtr->value.objPtr; - } - - resultPtr = Tcl_NewObj(); - - /* - * An error. If the variable doesn't exist anymore and no-one's using - * it, then free up the relevant structures and hash table entries. - */ - - errorReturn: - if (varPtr != NULL) { - if (TclIsVarUndefined(varPtr)) { - CleanupVar(varPtr, NULL); /* note: array isn't in hashtable */ - } - } - return resultPtr; -} - -/* - *---------------------------------------------------------------------- - * * TclIncrVar2 -- * * Given a two-part variable name, which may refer either to a scalar @@ -1815,96 +1733,75 @@ TclIncrVar2(interp, part1Ptr, part2Ptr, incrAmount, flags) * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */ { - register Tcl_Obj *varValuePtr; - Tcl_Obj *resultPtr; - int createdNewObj; /* Set 1 if var's value object is shared - * so we must increment a copy (i.e. copy - * on write). */ - long i; - int result; + Var *varPtr, *arrayPtr; + char *part1, *part2; - varValuePtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); - if (varValuePtr == NULL) { + part1 = TclGetString(part1Ptr); + part2 = ((part2Ptr == NULL)? NULL : TclGetString(part2Ptr)); + + varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read", + 0, 1, &arrayPtr); + if (varPtr == NULL) { Tcl_AddObjErrorInfo(interp, "\n (reading value of variable to increment)", -1); return NULL; } - - /* - * Increment the variable's value. If the object is unshared we can - * modify it directly, otherwise we must create a new copy to modify: - * this is "copy on write". Then free the variable's old string - * representation, if any, since it will no longer be valid. - */ - - createdNewObj = 0; - if (Tcl_IsShared(varValuePtr)) { - varValuePtr = Tcl_DuplicateObj(varValuePtr); - createdNewObj = 1; - } - result = Tcl_GetLongFromObj(interp, varValuePtr, &i); - if (result != TCL_OK) { - if (createdNewObj) { - Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ - } - return NULL; - } - Tcl_SetLongObj(varValuePtr, (i + incrAmount)); - - /* - * Store the variable's new value and run any write traces. - */ - - resultPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, varValuePtr, flags); - if (resultPtr == NULL) { - return NULL; - } - return resultPtr; + return TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, + incrAmount, flags); } /* *---------------------------------------------------------------------- * - * TclIncrIndexedScalar -- + * TclPtrIncrVar -- * - * Increments the Tcl object value of a local scalar variable in the - * active procedure, given its compile-time allocated index in the - * procedure's array of local variables. + * Given the pointers to a variable and possible containing array, + * increment the Tcl object value of the variable by a specified + * amount. * * Results: * Returns a pointer to the Tcl_Obj holding the new value of the - * variable given by localIndex. If the specified variable doesn't - * exist, or there is a clash in array usage, or an error occurs while - * executing variable traces, then NULL is returned and a message will - * be left in the interpreter's result. + * variable. If the specified variable doesn't exist, or there is a + * clash in array usage, or an error occurs while executing variable + * traces, then NULL is returned and a message will be left in + * the interpreter's result. * * Side effects: * The value of the given variable is incremented by the specified - * amount. The ref count for the returned object is _not_ incremented - * to reflect the returned reference; if you want to keep a reference - * to the object you must increment its ref count yourself. + * amount. If either the array or the entry didn't exist then a new + * variable is created. The ref count for the returned object is _not_ + * incremented to reflect the returned reference; if you want to keep a + * reference to the object you must increment its ref count yourself. * *---------------------------------------------------------------------- */ Tcl_Obj * -TclIncrIndexedScalar(interp, localIndex, incrAmount) +TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags) Tcl_Interp *interp; /* Command interpreter in which variable is * to be found. */ - int localIndex; /* Index of variable in procedure's array - * of local variables. */ - long incrAmount; /* Amount to be added to variable. */ + Var *varPtr; + Var *arrayPtr; + CONST char *part1; /* Points to an object holding the name of + * an array (if part2 is non-NULL) or the + * name of a variable. */ + CONST char *part2; /* If non-null, points to an object holding + * the name of an element in the array + * part1Ptr. */ + CONST long incrAmount; /* Amount to be added to variable. */ + CONST int flags; /* Various flags that tell how to incr value: + * any of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE, + * TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */ { register Tcl_Obj *varValuePtr; - Tcl_Obj *resultPtr; int createdNewObj; /* Set 1 if var's value object is shared * so we must increment a copy (i.e. copy * on write). */ long i; - int result; - varValuePtr = TclGetIndexedScalar(interp, localIndex, - /*leaveErrorMsg*/ 1); + varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags); + if (varValuePtr == NULL) { Tcl_AddObjErrorInfo(interp, "\n (reading value of variable to increment)", -1); @@ -1912,125 +1809,58 @@ TclIncrIndexedScalar(interp, localIndex, incrAmount) } /* - * Reach into the object's representation to extract and increment the - * variable's value. If the object is unshared we can modify it - * directly, otherwise we must create a new copy to modify: this is - * "copy on write". Then free the variable's old string representation, - * if any, since it will no longer be valid. + * Increment the variable's value. If the object is unshared we can + * modify it directly, otherwise we must create a new copy to modify: + * this is "copy on write". Then free the variable's old string + * representation, if any, since it will no longer be valid. */ createdNewObj = 0; if (Tcl_IsShared(varValuePtr)) { - createdNewObj = 1; varValuePtr = Tcl_DuplicateObj(varValuePtr); + createdNewObj = 1; } - result = Tcl_GetLongFromObj(interp, varValuePtr, &i); - if (result != TCL_OK) { +#ifdef TCL_WIDE_INT_IS_LONG + if (Tcl_GetLongFromObj(interp, varValuePtr, &i) != TCL_OK) { if (createdNewObj) { Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ } return NULL; } Tcl_SetLongObj(varValuePtr, (i + incrAmount)); - - /* - * Store the variable's new value and run any write traces. - */ - - resultPtr = TclSetIndexedScalar(interp, localIndex, varValuePtr, - /*leaveErrorMsg*/ 1); - if (resultPtr == NULL) { - return NULL; - } - return resultPtr; -} - -/* - *---------------------------------------------------------------------- - * - * TclIncrElementOfIndexedArray -- - * - * Increments the Tcl object value of an element in a local array - * variable. The element is named by the object elemPtr while the array - * is specified by its index in the active procedure's array of - * compiler allocated local variables. - * - * Results: - * Returns a pointer to the Tcl_Obj holding the new value of the - * element. If the specified array or element doesn't exist, or there - * is a clash in array usage, or an error occurs while executing - * variable traces, then NULL is returned and a message will be left in - * the interpreter's result. - * - * Side effects: - * The value of the given array element is incremented by the specified - * amount. The ref count for the returned object is _not_ incremented - * to reflect the returned reference; if you want to keep a reference - * to the object you must increment its ref count yourself. If the - * entry doesn't exist then a new variable is created. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclIncrElementOfIndexedArray(interp, localIndex, elemPtr, incrAmount) - Tcl_Interp *interp; /* Command interpreter in which the array is - * to be found. */ - int localIndex; /* Index of array variable in procedure's - * array of local variables. */ - Tcl_Obj *elemPtr; /* Points to an object holding the name of - * an element to increment in the array. */ - long incrAmount; /* Amount to be added to variable. */ -{ - register Tcl_Obj *varValuePtr; - Tcl_Obj *resultPtr; - int createdNewObj; /* Set 1 if var's value object is shared - * so we must increment a copy (i.e. copy - * on write). */ - long i; - int result; - - varValuePtr = TclGetElementOfIndexedArray(interp, localIndex, elemPtr, - /*leaveErrorMsg*/ 1); - if (varValuePtr == NULL) { - Tcl_AddObjErrorInfo(interp, - "\n (reading value of variable to increment)", -1); - return NULL; - } - - /* - * Reach into the object's representation to extract and increment the - * variable's value. If the object is unshared we can modify it - * directly, otherwise we must create a new copy to modify: this is - * "copy on write". Then free the variable's old string representation, - * if any, since it will no longer be valid. - */ - - createdNewObj = 0; - if (Tcl_IsShared(varValuePtr)) { - createdNewObj = 1; - varValuePtr = Tcl_DuplicateObj(varValuePtr); - } - result = Tcl_GetLongFromObj(interp, varValuePtr, &i); - if (result != TCL_OK) { - if (createdNewObj) { - Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ +#else + if (varValuePtr->typePtr == &tclWideIntType) { + Tcl_WideInt wide = varValuePtr->internalRep.wideValue; + Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); + } else if (varValuePtr->typePtr == &tclIntType) { + i = varValuePtr->internalRep.longValue; + Tcl_SetIntObj(varValuePtr, i + incrAmount); + } else { + /* + * Not an integer or wide internal-rep... + */ + Tcl_WideInt wide; + if (Tcl_GetWideIntFromObj(interp, varValuePtr, &wide) != TCL_OK) { + if (createdNewObj) { + Tcl_DecrRefCount(varValuePtr); /* free unneeded copy */ + } + return NULL; + } + if (wide <= Tcl_LongAsWide(LONG_MAX) + && wide >= Tcl_LongAsWide(LONG_MIN)) { + Tcl_SetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount); + } else { + Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount)); } - return NULL; } - Tcl_SetLongObj(varValuePtr, (i + incrAmount)); - +#endif + /* * Store the variable's new value and run any write traces. */ - resultPtr = TclSetElementOfIndexedArray(interp, localIndex, elemPtr, - varValuePtr, - /*leaveErrorMsg*/ 1); - if (resultPtr == NULL) { - return NULL; - } - return resultPtr; + return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, + varValuePtr, flags); } /* @@ -2057,7 +1887,7 @@ int Tcl_UnsetVar(interp, varName, flags) Tcl_Interp *interp; /* Command interpreter in which varName is * to be looked up. */ - char *varName; /* Name of a variable in interp. May be + CONST char *varName; /* Name of a variable in interp. May be * either a scalar name or an array name * or an element in an array. */ int flags; /* OR-ed combination of any of @@ -2092,8 +1922,51 @@ int Tcl_UnsetVar2(interp, part1, part2, flags) Tcl_Interp *interp; /* Command interpreter in which varName is * to be looked up. */ - char *part1; /* Name of variable or array. */ - char *part2; /* Name of element within array or NULL. */ + CONST char *part1; /* Name of variable or array. */ + CONST char *part2; /* Name of element within array or NULL. */ + int flags; /* OR-ed combination of any of + * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * TCL_LEAVE_ERR_MSG. */ +{ + int result; + Tcl_Obj *part1Ptr; + + part1Ptr = Tcl_NewStringObj(part1, -1); + Tcl_IncrRefCount(part1Ptr); + result = TclObjUnsetVar2(interp, part1Ptr, part2, flags); + TclDecrRefCount(part1Ptr); + + return result; +} + + +/* + *---------------------------------------------------------------------- + * + * TclObjUnsetVar2 -- + * + * Delete a variable, given a 2-object name. + * + * Results: + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR + * if the variable can't be unset. In the event of an error, + * if the TCL_LEAVE_ERR_MSG flag is set then an error message + * is left in the interp's result. + * + * Side effects: + * If part1ptr and part2Ptr indicate a local or global variable in interp, + * it is deleted. If part1Ptr is an array name and part2Ptr is NULL, then + * the whole array is deleted. + * + *---------------------------------------------------------------------- + */ + +int +TclObjUnsetVar2(interp, part1Ptr, part2, flags) + Tcl_Interp *interp; /* Command interpreter in which varName is + * to be looked up. */ + Tcl_Obj *part1Ptr; /* Name of variable or array. */ + CONST char *part2; /* Name of element within array or NULL. */ int flags; /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ @@ -2105,12 +1978,15 @@ Tcl_UnsetVar2(interp, part1, part2, flags) ActiveVarTrace *activePtr; Tcl_Obj *objPtr; int result; + char *part1; - varPtr = TclLookupVar(interp, part1, part2, flags, "unset", + part1 = TclGetString(part1Ptr); + varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "unset", /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; } + result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK); if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) { @@ -2141,7 +2017,7 @@ Tcl_UnsetVar2(interp, part1, part2, flags) * Call trace procedures for the variable being deleted. Then delete * its traces. Be sure to abort any other traces for the variable * that are still pending. Special tricks: - * 1. We need to increment varPtr's refCount around this: CallTraces + * 1. We need to increment varPtr's refCount around this: CallVarTraces * will use dummyVar so it won't increment varPtr's refCount itself. * 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to * call unset traces even if other traces are pending. @@ -2151,14 +2027,15 @@ Tcl_UnsetVar2(interp, part1, part2, flags) || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { varPtr->refCount++; dummyVar.flags &= ~VAR_TRACE_ACTIVE; - (void) CallTraces(iPtr, arrayPtr, &dummyVar, part1, part2, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); + CallVarTraces(iPtr, arrayPtr, &dummyVar, part1, part2, + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) + | TCL_TRACE_UNSETS, /* leaveErrMsg */ 0); while (dummyVar.tracePtr != NULL) { VarTrace *tracePtr = dummyVar.tracePtr; dummyVar.tracePtr = tracePtr->nextPtr; - ckfree((char *) tracePtr); + Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); } - for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; @@ -2190,7 +2067,8 @@ Tcl_UnsetVar2(interp, part1, part2, flags) */ varPtr->refCount++; DeleteArray(iPtr, part1, dummyVarPtr, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) + | TCL_TRACE_UNSETS); /* Decr ref count */ varPtr->refCount--; } @@ -2256,7 +2134,7 @@ int Tcl_TraceVar(interp, varName, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter in which variable is * to be traced. */ - char *varName; /* Name of variable; may end with "(index)" + CONST char *varName; /* Name of variable; may end with "(index)" * to signify an array reference. */ int flags; /* OR-ed collection of bits, including any * of TCL_TRACE_READS, TCL_TRACE_WRITES, @@ -2295,8 +2173,8 @@ int Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter in which variable is * to be traced. */ - char *part1; /* Name of scalar variable or array. */ - char *part2; /* Name of element within array; NULL means + CONST char *part1; /* Name of scalar variable or array. */ + CONST char *part2; /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ int flags; /* OR-ed collection of bits, including any @@ -2309,25 +2187,46 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) { Var *varPtr, *arrayPtr; register VarTrace *tracePtr; - - varPtr = TclLookupVar(interp, part1, part2, (flags | TCL_LEAVE_ERR_MSG), + int flagMask; + + /* + * We strip 'flags' down to just the parts which are relevant to + * TclLookupVar, to avoid conflicts between trace flags and + * internal namespace flags such as 'FIND_ONLY_NS'. This can + * now occur since we have trace flags with values 0x1000 and higher. + */ + flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; + varPtr = TclLookupVar(interp, part1, part2, + (flags & flagMask) | TCL_LEAVE_ERR_MSG, "trace", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; } /* + * Check for a nonsense flag combination. Note that this is a + * panic() because there should be no code path that ever sets + * both flags. + */ + if ((flags&TCL_TRACE_RESULT_DYNAMIC) && (flags&TCL_TRACE_RESULT_OBJECT)) { + panic("bad result flag combination"); + } + + /* * Set up trace information. */ + flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; +#ifndef TCL_REMOVE_OBSOLETE_TRACES + flagMask |= TCL_TRACE_OLD_STYLE; +#endif tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace)); - tracePtr->traceProc = proc; - tracePtr->clientData = clientData; - tracePtr->flags = - flags & (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | - TCL_TRACE_ARRAY); - tracePtr->nextPtr = varPtr->tracePtr; - varPtr->tracePtr = tracePtr; + tracePtr->traceProc = proc; + tracePtr->clientData = clientData; + tracePtr->flags = flags & flagMask; + tracePtr->nextPtr = varPtr->tracePtr; + varPtr->tracePtr = tracePtr; return TCL_OK; } @@ -2352,7 +2251,7 @@ Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData) void Tcl_UntraceVar(interp, varName, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter containing variable. */ - char *varName; /* Name of variable; may end with "(index)" + CONST char *varName; /* Name of variable; may end with "(index)" * to signify an array reference. */ int flags; /* OR-ed collection of bits describing * current trace, including any of @@ -2386,8 +2285,8 @@ Tcl_UntraceVar(interp, varName, flags, proc, clientData) void Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) Tcl_Interp *interp; /* Interpreter containing variable. */ - char *part1; /* Name of variable or array. */ - char *part2; /* Name of element within array; NULL means + CONST char *part1; /* Name of variable or array. */ + CONST char *part2; /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ int flags; /* OR-ed collection of bits describing @@ -2403,17 +2302,31 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) Var *varPtr, *arrayPtr; Interp *iPtr = (Interp *) interp; ActiveVarTrace *activePtr; - - varPtr = TclLookupVar(interp, part1, part2, - flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY), + int flagMask; + + /* + * Set up a mask to mask out the parts of the flags that we are not + * interested in now. + */ + flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY; + varPtr = TclLookupVar(interp, part1, part2, flags & flagMask, /*msg*/ (char *) NULL, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); if (varPtr == NULL) { return; } - flags &= (TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | - TCL_TRACE_ARRAY); + + /* + * Set up a mask to mask out the parts of the flags that we are not + * interested in now. + */ + flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | + TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; +#ifndef TCL_REMOVE_OBSOLETE_TRACES + flagMask |= TCL_TRACE_OLD_STYLE; +#endif + flags &= flagMask; for (tracePtr = varPtr->tracePtr, prevPtr = NULL; ; prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) { if (tracePtr == NULL) { @@ -2428,10 +2341,10 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) /* * The code below makes it possible to delete traces while traces * are active: it makes sure that the deleted trace won't be - * processed by CallTraces. + * processed by CallVarTraces. */ - for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->nextTracePtr == tracePtr) { activePtr->nextTracePtr = tracePtr->nextPtr; @@ -2442,7 +2355,7 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) } else { prevPtr->nextPtr = tracePtr->nextPtr; } - ckfree((char *) tracePtr); + Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); /* * If this is the last trace on the variable, and the variable is @@ -2483,7 +2396,7 @@ Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData) ClientData Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) Tcl_Interp *interp; /* Interpreter containing variable. */ - char *varName; /* Name of variable; may end with "(index)" + CONST char *varName; /* Name of variable; may end with "(index)" * to signify an array reference. */ int flags; /* OR-ed combo or TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY (can be 0). */ @@ -2518,8 +2431,8 @@ Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) ClientData Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData) Tcl_Interp *interp; /* Interpreter containing variable. */ - char *part1; /* Name of variable or array. */ - char *part2; /* Name of element within array; NULL means + CONST char *part1; /* Name of variable or array. */ + CONST char *part2; /* Name of element within array; NULL means * trace applies to scalar variable or array * as-a-whole. */ int flags; /* OR-ed combination of TCL_GLOBAL_ONLY, @@ -2589,18 +2502,45 @@ Tcl_UnsetObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - register int i; + register int i, flags = TCL_LEAVE_ERR_MSG; register char *name; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "varName ?varName ...?"); + if (objc < 1) { + Tcl_WrongNumArgs(interp, 1, objv, + "?-nocomplain? ?--? ?varName varName ...?"); return TCL_ERROR; + } else if (objc == 1) { + /* + * Do nothing if no arguments supplied, so as to match + * command documentation. + */ + return TCL_OK; } - - for (i = 1; i < objc; i++) { - name = TclGetString(objv[i]); - if (Tcl_UnsetVar2(interp, name, (char *) NULL, - TCL_LEAVE_ERR_MSG) != TCL_OK) { + + /* + * Simple, restrictive argument parsing. The only options are -- + * and -nocomplain (which must come first and be given exactly to + * be an option). + */ + i = 1; + name = TclGetString(objv[i]); + if (name[0] == '-') { + if (strcmp("-nocomplain", name) == 0) { + i++; + if (i == objc) { + return TCL_OK; + } + flags = 0; + name = TclGetString(objv[i]); + } + if (strcmp("--", name) == 0) { + i++; + } + } + + for (; i < objc; i++) { + if ((TclObjUnsetVar2(interp, objv[i], NULL, flags) != TCL_OK) + && (flags == TCL_LEAVE_ERR_MSG)) { return TCL_ERROR; } } @@ -2632,6 +2572,9 @@ Tcl_AppendObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { + Var *varPtr, *arrayPtr; + char *part1; + register Tcl_Obj *varValuePtr = NULL; /* Initialized to avoid compiler * warning. */ @@ -2641,15 +2584,29 @@ Tcl_AppendObjCmd(dummy, interp, objc, objv) Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); return TCL_ERROR; } + if (objc == 2) { varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); if (varValuePtr == NULL) { return TCL_ERROR; } } else { - for (i = 2; i < objc; i++) { - varValuePtr = Tcl_ObjSetVar2(interp, objv[1], (Tcl_Obj *) NULL, - objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG)); + varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG, + "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + part1 = TclGetString(objv[1]); + if (varPtr == NULL) { + return TCL_ERROR; + } + for (i = 2; i < objc; i++) { + /* + * Note that we do not need to increase the refCount of + * the Var pointers: should a trace delete the variable, + * the return value of TclPtrSetVar will be NULL, and we + * will not access the variable again. + */ + + varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL, + objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG)); if (varValuePtr == NULL) { return TCL_ERROR; } @@ -2688,25 +2645,26 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) register List *listRepPtr; register Tcl_Obj **elemPtrs; int numElems, numRequired, createdNewObj, createVar, i, j; + Var *varPtr, *arrayPtr; + char *part1; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?"); return TCL_ERROR; } if (objc == 2) { - newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, - (TCL_LEAVE_ERR_MSG)); + newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, 0); if (newValuePtr == NULL) { /* * The variable doesn't exist yet. Just create it with an empty * initial value. */ - Tcl_Obj *nullObjPtr = Tcl_NewObj(); - newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, - nullObjPtr, TCL_LEAVE_ERR_MSG); + varValuePtr = Tcl_NewObj(); + newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr, + TCL_LEAVE_ERR_MSG); if (newValuePtr == NULL) { - Tcl_DecrRefCount(nullObjPtr); /* free unneeded object */ + Tcl_DecrRefCount(varValuePtr); /* free unneeded object */ return TCL_ERROR; } } @@ -2723,27 +2681,41 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) createdNewObj = 0; createVar = 1; - varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); + + /* + * Use the TCL_TRACE_READS flag to ensure that if we have an + * array with no elements set yet, but with a read trace on it, + * we will create the variable and get read traces triggered. + * Note that you have to protect the variable pointers around + * the TclPtrGetVar call to insure that they remain valid + * even if the variable was undefined and unused. + */ + + varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG, + "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } + varPtr->refCount++; + if (arrayPtr != NULL) { + arrayPtr->refCount++; + } + part1 = TclGetString(objv[1]); + varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, NULL, + (TCL_TRACE_READS | TCL_LEAVE_ERR_MSG)); + varPtr->refCount--; + if (arrayPtr != NULL) { + arrayPtr->refCount--; + } + if (varValuePtr == NULL) { /* * We couldn't read the old value: either the var doesn't yet - * exist or it's an array element. If it's new, we will try to + * exist or it's an array element. If it's new, we will try to * create it with Tcl_ObjSetVar2 below. */ - char *p, *varName; - int nameBytes, i; - - varName = Tcl_GetStringFromObj(objv[1], &nameBytes); - for (i = 0, p = varName; i < nameBytes; i++, p++) { - if (*p == '(') { - p = (varName + nameBytes-1); - if (*p == ')') { /* last char is ')' => array ref */ - createVar = 0; - } - break; - } - } + createVar = (TclIsVarUndefined(varPtr)); varValuePtr = Tcl_NewObj(); createdNewObj = 1; } else if (Tcl_IsShared(varValuePtr)) { @@ -2764,7 +2736,7 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) return result; } } - listRepPtr = (List *) varValuePtr->internalRep.otherValuePtr; + listRepPtr = (List *) varValuePtr->internalRep.twoPtrValue.ptr1; elemPtrs = listRepPtr->elements; numElems = listRepPtr->elemCount; @@ -2810,8 +2782,8 @@ Tcl_LappendObjCmd(dummy, interp, objc, objv) * was new and we didn't create the variable. */ - newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr, - TCL_LEAVE_ERR_MSG); + newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL, + varValuePtr, TCL_LEAVE_ERR_MSG); if (newValuePtr == NULL) { if (createdNewObj && !createVar) { Tcl_DecrRefCount(varValuePtr); /* free unneeded obj */ @@ -2861,18 +2833,18 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) enum {ARRAY_ANYMORE, ARRAY_DONESEARCH, ARRAY_EXISTS, ARRAY_GET, ARRAY_NAMES, ARRAY_NEXTELEMENT, ARRAY_SET, ARRAY_SIZE, - ARRAY_STARTSEARCH, ARRAY_UNSET}; - static char *arrayOptions[] = { + ARRAY_STARTSEARCH, ARRAY_STATISTICS, ARRAY_UNSET}; + static CONST char *arrayOptions[] = { "anymore", "donesearch", "exists", "get", "names", "nextelement", - "set", "size", "startsearch", "unset", (char *) NULL + "set", "size", "startsearch", "statistics", "unset", (char *) NULL }; Interp *iPtr = (Interp *) interp; Var *varPtr, *arrayPtr; Tcl_HashEntry *hPtr; - Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + Tcl_Obj *resultPtr, *varNamePtr; int notArray; - char *varName, *msg; + char *varName; int index, result; @@ -2887,38 +2859,50 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } /* - * Locate the array variable (and it better be an array). + * Locate the array variable */ - varName = TclGetString(objv[2]); - varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0, + varNamePtr = objv[2]; + varName = TclGetString(varNamePtr); + varPtr = TclObjLookupVar(interp, varNamePtr, NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - notArray = 0; - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - notArray = 1; - } - /* * Special array trace used to keep the env array in sync for * array names, array get, etc. */ - if (varPtr != NULL && varPtr->tracePtr != NULL) { - msg = CallTraces(iPtr, arrayPtr, varPtr, varName, NULL, + if (varPtr != NULL && varPtr->tracePtr != NULL + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, varName, NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY)); - if (msg != NULL) { - VarErrMsg(interp, varName, NULL, "trace array", msg); + TCL_TRACE_ARRAY), /* leaveErrMsg */ 1)) { return TCL_ERROR; } } + /* + * Verify that it is indeed an array variable. This test comes after + * the traces - the variable may actually become an array as an effect + * of said traces. + */ + + notArray = 0; + if ((varPtr == NULL) || !TclIsVarArray(varPtr) + || TclIsVarUndefined(varPtr)) { + notArray = 1; + } + + /* + * We have to wait to get the resultPtr until here because + * CallVarTraces can affect the result. + */ + + resultPtr = Tcl_GetObjResult(interp); + switch (index) { case ARRAY_ANYMORE: { ArraySearch *searchPtr; - char *searchId; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, @@ -2928,8 +2912,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (notArray) { goto error; } - searchId = Tcl_GetString(objv[3]); - searchPtr = ParseSearchId(interp, varPtr, varName, searchId); + searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); if (searchPtr == NULL) { return TCL_ERROR; } @@ -2953,7 +2936,6 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } case ARRAY_DONESEARCH: { ArraySearch *searchPtr, *prevPtr; - char *searchId; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, @@ -2963,8 +2945,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (notArray) { goto error; } - searchId = Tcl_GetString(objv[3]); - searchPtr = ParseSearchId(interp, varPtr, varName, searchId); + searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); if (searchPtr == NULL) { return TCL_ERROR; } @@ -2995,7 +2976,8 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) Var *varPtr2; char *pattern = NULL; char *name; - Tcl_Obj *namePtr, *valuePtr; + Tcl_Obj *namePtr, *valuePtr, *nameLstPtr, *tmpResPtr, **namePtrPtr; + int i, count; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); @@ -3007,6 +2989,14 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (objc == 4) { pattern = TclGetString(objv[3]); } + + /* + * Store the array names in a new object. + */ + + nameLstPtr = Tcl_NewObj(); + Tcl_IncrRefCount(nameLstPtr); + for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); @@ -3019,27 +3009,75 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } namePtr = Tcl_NewStringObj(name, -1); - result = Tcl_ListObjAppendElement(interp, resultPtr, + result = Tcl_ListObjAppendElement(interp, nameLstPtr, namePtr); if (result != TCL_OK) { Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ + Tcl_DecrRefCount(nameLstPtr); return result; } + } + + /* + * Make sure the Var structure of the array is not removed by + * a trace while we're working. + */ + + varPtr->refCount++; + + /* + * Get the array values corresponding to each element name + */ + tmpResPtr = Tcl_NewObj(); + result = Tcl_ListObjGetElements(interp, nameLstPtr, + &count, &namePtrPtr); + if (result != TCL_OK) { + goto errorInArrayGet; + } + + for (i = 0; i < count; i++) { + namePtr = *namePtrPtr++; valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr, TCL_LEAVE_ERR_MSG); if (valuePtr == NULL) { - Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ - return result; + /* + * Some trace played a trick on us; we need to diagnose to + * adapt our behaviour: was the array element unset, or did + * the modification modify the complete array? + */ + + if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { + /* + * The array itself looks OK, the variable was + * undefined: forget it. + */ + + continue; + } else { + result = TCL_ERROR; + goto errorInArrayGet; + } } - result = Tcl_ListObjAppendElement(interp, resultPtr, - valuePtr); + result = Tcl_ListObjAppendElement(interp, tmpResPtr, namePtr); if (result != TCL_OK) { - Tcl_DecrRefCount(namePtr); /* free unneeded name obj */ - return result; + goto errorInArrayGet; + } + result = Tcl_ListObjAppendElement(interp, tmpResPtr, valuePtr); + if (result != TCL_OK) { + goto errorInArrayGet; } } + varPtr->refCount--; + Tcl_SetObjResult(interp, tmpResPtr); + Tcl_DecrRefCount(nameLstPtr); break; + + errorInArrayGet: + varPtr->refCount--; + Tcl_DecrRefCount(nameLstPtr); + Tcl_DecrRefCount(tmpResPtr); /* free unneeded temp result obj */ + return result; } case ARRAY_NAMES: { Tcl_HashSearch search; @@ -3047,9 +3085,17 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) char *pattern = NULL; char *name; Tcl_Obj *namePtr; + int mode, matched = 0; + static CONST char *options[] = { + "-exact", "-glob", "-regexp", (char *) NULL + }; + enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; + + mode = OPT_GLOB; - if ((objc != 3) && (objc != 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); + if ((objc < 3) && (objc > 5)) { + Tcl_WrongNumArgs(interp, 2, objv, + "arrayName ?mode? ?pattern?"); return TCL_ERROR; } if (notArray) { @@ -3057,7 +3103,13 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } if (objc == 4) { pattern = Tcl_GetString(objv[3]); - } + } else if (objc == 5) { + pattern = Tcl_GetString(objv[4]); + if (Tcl_GetIndexFromObj(interp, objv[3], options, "option", + 0, &mode) != TCL_OK) { + return TCL_ERROR; + } + } for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); @@ -3065,8 +3117,25 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) continue; } name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); - if ((objc == 4) && !Tcl_StringMatch(name, pattern)) { - continue; /* element name doesn't match pattern */ + if (objc > 3) { + switch ((enum options) mode) { + case OPT_EXACT: + matched = (strcmp(name, pattern) == 0); + break; + case OPT_GLOB: + matched = Tcl_StringMatch(name, pattern); + break; + case OPT_REGEXP: + matched = Tcl_RegExpMatch(interp, name, + pattern); + if (matched < 0) { + return TCL_ERROR; + } + break; + } + if (matched == 0) { + continue; + } } namePtr = Tcl_NewStringObj(name, -1); @@ -3080,7 +3149,6 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } case ARRAY_NEXTELEMENT: { ArraySearch *searchPtr; - char *searchId; Tcl_HashEntry *hPtr; if (objc != 4) { @@ -3091,8 +3159,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) if (notArray) { goto error; } - searchId = Tcl_GetString(objv[3]); - searchPtr = ParseSearchId(interp, varPtr, varName, searchId); + searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); if (searchPtr == NULL) { return TCL_ERROR; } @@ -3178,7 +3245,27 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) varPtr->searchPtr = searchPtr; break; } - case ARRAY_UNSET: { + + case ARRAY_STATISTICS: { + CONST char *stats; + + if (notArray) { + goto error; + } + + stats = Tcl_HashStats(varPtr->value.tablePtr); + if (stats != NULL) { + Tcl_SetStringObj(Tcl_GetObjResult(interp), stats, -1); + ckfree((void *)stats); + } else { + Tcl_SetResult(interp, "error reading array statistics", + TCL_STATIC); + return TCL_ERROR; + } + break; + } + + case ARRAY_UNSET: { Tcl_HashSearch search; Var *varPtr2; char *pattern = NULL; @@ -3195,7 +3282,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) /* * When no pattern is given, just unset the whole array */ - if (Tcl_UnsetVar2(interp, varName, (char *) NULL, 0) + if (TclObjUnsetVar2(interp, varNamePtr, NULL, 0) != TCL_OK) { return TCL_ERROR; } @@ -3210,7 +3297,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); if (Tcl_StringMatch(name, pattern) && - (Tcl_UnsetVar2(interp, varName, name, 0) + (TclObjUnsetVar2(interp, varNamePtr, name, 0) != TCL_OK)) { return TCL_ERROR; } @@ -3254,26 +3341,26 @@ TclArraySet(interp, arrayNameObj, arrayElemObj) { Var *varPtr, *arrayPtr; Tcl_Obj **elemPtrs; - int result, elemLen, i; + int result, elemLen, i, nameLen; char *varName, *p; - varName = TclGetString(arrayNameObj); - for (p = varName; *p ; p++) { - if (*p == '(') { - do { - p++; - } while (*p != '\0'); - p--; - if (*p == ')') { + varName = Tcl_GetStringFromObj(arrayNameObj, &nameLen); + p = varName + nameLen - 1; + if (*p == ')') { + while (--p >= varName) { + if (*p == '(') { VarErrMsg(interp, varName, NULL, "set", needArray); return TCL_ERROR; } - break; } } - varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + varPtr = TclObjLookupVar(interp, arrayNameObj, NULL, + /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1, + /*createPart2*/ 0, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } if (arrayElemObj != NULL) { result = Tcl_ListObjGetElements(interp, arrayElemObj, @@ -3288,9 +3375,19 @@ TclArraySet(interp, arrayNameObj, arrayElemObj) return TCL_ERROR; } if (elemLen > 0) { + /* + * We needn't worry about traces invalidating arrayPtr: + * should that be the case, TclPtrSetVar will return NULL + * so that we break out of the loop and return an error. + */ + for (i = 0; i < elemLen; i += 2) { - if (Tcl_ObjSetVar2(interp, arrayNameObj, elemPtrs[i], - elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL) { + char *part2 = TclGetString(elemPtrs[i]); + Var *elemVarPtr = TclLookupArrayElement(interp, varName, + part2, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr); + if ((elemVarPtr == NULL) || + (TclPtrSetVar(interp, elemVarPtr, varPtr, varName, + part2, elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL)) { result = TCL_ERROR; break; } @@ -3320,22 +3417,6 @@ TclArraySet(interp, arrayNameObj, arrayElemObj) VarErrMsg(interp, varName, (char *)NULL, "array set", needArray); return TCL_ERROR; } - } else { - /* - * Create variable for new array. - */ - - varPtr = TclLookupVar(interp, varName, (char *) NULL, - TCL_LEAVE_ERR_MSG, "set", - /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); - - /* - * Still couldn't do it - this can occur if a non-existent - * namespace was specified - */ - if (varPtr == NULL) { - return TCL_ERROR; - } } TclSetVarArray(varPtr); TclClearVarUndefined(varPtr); @@ -3348,7 +3429,7 @@ TclArraySet(interp, arrayNameObj, arrayElemObj) /* *---------------------------------------------------------------------- * - * MakeUpvar -- + * ObjMakeUpvar -- * * This procedure does all of the work of the "global" and "upvar" * commands. @@ -3366,158 +3447,101 @@ TclArraySet(interp, arrayNameObj, arrayElemObj) */ static int -MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags) - Interp *iPtr; /* Interpreter containing variables. Used - * for error messages, too. */ +ObjMakeUpvar(interp, framePtr, otherP1Ptr, otherP2, otherFlags, myName, myFlags, index) + Tcl_Interp *interp; /* Interpreter containing variables. Used + * for error messages, too. */ CallFrame *framePtr; /* Call frame containing "other" variable. * NULL means use global :: context. */ - char *otherP1, *otherP2; /* Two-part name of variable in framePtr. */ - int otherFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: + Tcl_Obj *otherP1Ptr; + CONST char *otherP2; /* Two-part name of variable in framePtr. */ + CONST int otherFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: * indicates scope of "other" variable. */ - char *myName; /* Name of variable which will refer to + CONST char *myName; /* Name of variable which will refer to * otherP1/otherP2. Must be a scalar. */ - int myFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: + CONST 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. */ { - Tcl_HashEntry *hPtr; + Interp *iPtr = (Interp *) interp; Var *otherPtr, *varPtr, *arrayPtr; CallFrame *varFramePtr; - CallFrame *savedFramePtr = NULL; /* Init. to avoid compiler warning. */ - Tcl_HashTable *tablePtr; - Namespace *nsPtr, *altNsPtr, *dummyNsPtr; - char *tail; - int new; + CONST char *errMsg; /* * Find "other" in "framePtr". If not looking up other in just the * current namespace, temporarily replace the current var frame - * pointer in the interpreter in order to use TclLookupVar. + * pointer in the interpreter in order to use TclObjLookupVar. */ + varFramePtr = iPtr->varFramePtr; if (!(otherFlags & TCL_NAMESPACE_ONLY)) { - savedFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = framePtr; } - otherPtr = TclLookupVar((Tcl_Interp *) iPtr, otherP1, otherP2, + otherPtr = TclObjLookupVar(interp, otherP1Ptr, otherP2, (otherFlags | TCL_LEAVE_ERR_MSG), "access", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (!(otherFlags & TCL_NAMESPACE_ONLY)) { - iPtr->varFramePtr = savedFramePtr; + iPtr->varFramePtr = varFramePtr; } if (otherPtr == NULL) { return TCL_ERROR; } - /* - * Now create a hashtable entry for "myName". Create it as either a - * namespace variable or as a local variable in a procedure call - * frame. Interpret myName as a namespace variable if: - * 1) so requested by a TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY flag, - * 2) there is no active frame (we're at the global :: scope), - * 3) the active frame was pushed to define the namespace context - * for a "namespace eval" or "namespace inscope" command, - * 4) the name has namespace qualifiers ("::"s). - * If creating myName in the active procedure, look first in the - * frame's array of compiler-allocated local variables, then in its - * hashtable for runtime-created local variables. Create that - * procedure's local variable hashtable if necessary. - */ - - varFramePtr = iPtr->varFramePtr; - if ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) - || (varFramePtr == NULL) - || !varFramePtr->isProcCallFrame - || (strstr(myName, "::") != NULL)) { - TclGetNamespaceForQualName((Tcl_Interp *) iPtr, myName, - (Namespace *) NULL, myFlags, &nsPtr, &altNsPtr, &dummyNsPtr, &tail); - - if (nsPtr == NULL) { - nsPtr = altNsPtr; - } - if (nsPtr == NULL) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", - myName, "\": unknown namespace", (char *) NULL); - return TCL_ERROR; - } - + if (index >= 0) { + if (!varFramePtr->isProcCallFrame) { + panic("ObjMakeUpVar called with an index outside from a proc.\n"); + } + varPtr = &(varFramePtr->compiledLocals[index]); + } else { /* * Check that we are not trying to create a namespace var linked to * a local variable in a procedure. If we allowed this, the local * variable in the shorter-lived procedure frame could go away * leaving the namespace var's reference invalid. */ - - if ((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL) { + + if (((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL) + && ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) + || (varFramePtr == NULL) + || !varFramePtr->isProcCallFrame + || (strstr(myName, "::") != NULL))) { Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", - myName, "\": upvar won't create namespace variable that refers to procedure variable", - (char *) NULL); - return TCL_ERROR; - } + myName, "\": upvar won't create namespace variable that ", + "refers to procedure variable", (char *) NULL); + return TCL_ERROR; + } - hPtr = Tcl_CreateHashEntry(&nsPtr->varTable, tail, &new); - if (new) { - varPtr = NewVar(); - Tcl_SetHashValue(hPtr, varPtr); - varPtr->hPtr = hPtr; - varPtr->nsPtr = nsPtr; - } else { - varPtr = (Var *) Tcl_GetHashValue(hPtr); + /* + * Lookup and eventually create the new variable. + */ + + varPtr = TclLookupSimpleVar(interp, myName, myFlags, /*create*/ 1, + &errMsg, &index); + if (varPtr == NULL) { + VarErrMsg(interp, myName, NULL, "create", errMsg); + return TCL_ERROR; } - } else { /* look in the call frame */ - Proc *procPtr = varFramePtr->procPtr; - int localCt = procPtr->numCompiledLocals; - CompiledLocal *localPtr = procPtr->firstLocalPtr; - Var *localVarPtr = varFramePtr->compiledLocals; - int nameLen = strlen(myName); - int i; + } - varPtr = NULL; - for (i = 0; i < localCt; i++) { - if (!TclIsVarTemporary(localPtr)) { - char *localName = localVarPtr->name; - if ((myName[0] == localName[0]) - && (nameLen == localPtr->nameLength) - && (strcmp(myName, localName) == 0)) { - varPtr = localVarPtr; - new = 0; - break; - } - } - localVarPtr++; - localPtr = localPtr->nextPtr; - } - if (varPtr == NULL) { /* look in frame's local var hashtable */ - tablePtr = varFramePtr->varTablePtr; - if (tablePtr == NULL) { - tablePtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS); - varFramePtr->varTablePtr = tablePtr; - } - hPtr = Tcl_CreateHashEntry(tablePtr, myName, &new); - if (new) { - varPtr = NewVar(); - Tcl_SetHashValue(hPtr, varPtr); - varPtr->hPtr = hPtr; - varPtr->nsPtr = varFramePtr->nsPtr; - } else { - varPtr = (Var *) Tcl_GetHashValue(hPtr); - } - } + if (varPtr == otherPtr) { + Tcl_SetResult((Tcl_Interp *) iPtr, + "can't upvar from variable to itself", TCL_STATIC); + return TCL_ERROR; } - if (!new) { + if (varPtr->tracePtr != NULL) { + Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, + "\" has traces: can't use for upvar", (char *) NULL); + return TCL_ERROR; + } else if (!TclIsVarUndefined(varPtr)) { /* - * The variable already exists. Make sure this variable "varPtr" + * The variable already existed. Make sure this variable "varPtr" * isn't the same as "otherPtr" (avoid circular links). Also, if * it's not an upvar then it's an error. If it is an upvar, then * just disconnect it from the thing it currently refers to. */ - if (varPtr == otherPtr) { - Tcl_SetResult((Tcl_Interp *) iPtr, - "can't upvar from variable to itself", TCL_STATIC); - return TCL_ERROR; - } if (TclIsVarLink(varPtr)) { Var *linkPtr = varPtr->value.linkPtr; if (linkPtr == otherPtr) { @@ -3527,14 +3551,10 @@ MakeUpvar(iPtr, framePtr, otherP1, otherP2, otherFlags, myName, myFlags) if (TclIsVarUndefined(linkPtr)) { CleanupVar(linkPtr, (Var *) NULL); } - } else if (!TclIsVarUndefined(varPtr)) { + } else { Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, "\" already exists", (char *) NULL); return TCL_ERROR; - } else if (varPtr->tracePtr != NULL) { - Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, - "\" has traces: can't use for upvar", (char *) NULL); - return TCL_ERROR; } } TclSetVarLink(varPtr); @@ -3569,52 +3589,16 @@ int Tcl_UpVar(interp, frameName, varName, localName, flags) Tcl_Interp *interp; /* Command interpreter in which varName is * to be looked up. */ - char *frameName; /* Name of the frame containing the source + CONST char *frameName; /* Name of the frame containing the source * variable, such as "1" or "#0". */ - char *varName; /* Name of a variable in interp to link to. + CONST char *varName; /* Name of a variable in interp to link to. * May be either a scalar name or an * element in an array. */ - char *localName; /* Name of link variable. */ + CONST char *localName; /* Name of link variable. */ int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: * indicates scope of localName. */ { - int result; - CallFrame *framePtr; - register char *p; - - result = TclGetFrame(interp, frameName, &framePtr); - if (result == -1) { - return TCL_ERROR; - } - - /* - * Figure out whether varName is an array reference, then call - * MakeUpvar to do all the real work. - */ - - for (p = varName; *p != '\0'; p++) { - if (*p == '(') { - char *openParen = p; - do { - p++; - } while (*p != '\0'); - p--; - if (*p != ')') { - goto scalar; - } - *openParen = '\0'; - *p = '\0'; - result = MakeUpvar((Interp *) interp, framePtr, varName, - openParen+1, 0, localName, flags); - *openParen = '('; - *p = ')'; - return result; - } - } - - scalar: - return MakeUpvar((Interp *) interp, framePtr, varName, (char *) NULL, - 0, localName, flags); + return Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags); } /* @@ -3642,23 +3626,30 @@ int Tcl_UpVar2(interp, frameName, part1, part2, localName, flags) Tcl_Interp *interp; /* Interpreter containing variables. Used * for error messages too. */ - char *frameName; /* Name of the frame containing the source + CONST char *frameName; /* Name of the frame containing the source * variable, such as "1" or "#0". */ - char *part1, *part2; /* Two parts of source variable name to + CONST char *part1; + CONST char *part2; /* Two parts of source variable name to * link to. */ - char *localName; /* Name of link variable. */ + CONST char *localName; /* Name of link variable. */ int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: * indicates scope of localName. */ { int result; CallFrame *framePtr; + Tcl_Obj *part1Ptr; - result = TclGetFrame(interp, frameName, &framePtr); - if (result == -1) { + if (TclGetFrame(interp, frameName, &framePtr) == -1) { return TCL_ERROR; } - return MakeUpvar((Interp *) interp, framePtr, part1, part2, 0, - localName, flags); + + part1Ptr = Tcl_NewStringObj(part1, -1); + Tcl_IncrRefCount(part1Ptr); + result = ObjMakeUpvar(interp, framePtr, part1Ptr, part2, 0, + localName, flags, -1); + TclDecrRefCount(part1Ptr); + + return result; } /* @@ -3779,7 +3770,7 @@ Tcl_GlobalObjCmd(dummy, interp, objc, objv) while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) { tail--; } - if (*tail == ':') { + if ((*tail == ':') && (tail > varName)) { tail++; } @@ -3787,9 +3778,9 @@ Tcl_GlobalObjCmd(dummy, interp, objc, objv) * Link to the variable "varName" in the global :: namespace. */ - result = MakeUpvar(iPtr, (CallFrame *) NULL, - varName, (char *) NULL, /*otherFlags*/ TCL_GLOBAL_ONLY, - /*myName*/ tail, /*myFlags*/ 0); + result = ObjMakeUpvar(interp, (CallFrame *) NULL, + objPtr, NULL, /*otherFlags*/ TCL_GLOBAL_ONLY, + /*myName*/ tail, /*myFlags*/ 0, -1); if (result != TCL_OK) { return result; } @@ -3844,6 +3835,12 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) Var *varPtr, *arrayPtr; Tcl_Obj *varValuePtr; int i, result; + Tcl_Obj *varNamePtr; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?name value...? name ?value?"); + return TCL_ERROR; + } for (i = 1; i < objc; i = i+2) { /* @@ -3851,8 +3848,9 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) * it if necessary. */ - varName = TclGetString(objv[i]); - varPtr = TclLookupVar(interp, varName, (char *) NULL, + varNamePtr = objv[i]; + varName = TclGetString(varNamePtr); + varPtr = TclObjLookupVar(interp, varNamePtr, NULL, (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "define", /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); @@ -3889,8 +3887,8 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) */ if (i+1 < objc) { /* a value was specified */ - varValuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, objv[i+1], - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG)); + varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, varName, NULL, + objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG)); if (varValuePtr == NULL) { return TCL_ERROR; } @@ -3924,10 +3922,10 @@ Tcl_VariableObjCmd(dummy, interp, objc, objv) * current namespace. */ - result = MakeUpvar(iPtr, (CallFrame *) NULL, - /*otherP1*/ varName, /*otherP2*/ (char *) NULL, + result = ObjMakeUpvar(interp, (CallFrame *) NULL, + /*otherP1*/ varNamePtr, /*otherP2*/ NULL, /*otherFlags*/ TCL_NAMESPACE_ONLY, - /*myName*/ tail, /*myFlags*/ 0); + /*myName*/ tail, /*myFlags*/ 0, -1); if (result != TCL_OK) { return result; } @@ -3961,10 +3959,8 @@ Tcl_UpvarObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - register Interp *iPtr = (Interp *) interp; CallFrame *framePtr; - char *frameSpec, *otherVarName, *myVarName; - register char *p; + char *frameSpec, *localName; int result; if (objc < 3) { @@ -3997,34 +3993,9 @@ Tcl_UpvarObjCmd(dummy, interp, objc, objv) */ for ( ; objc > 0; objc -= 2, objv += 2) { - myVarName = TclGetString(objv[1]); - otherVarName = TclGetString(objv[0]); - for (p = otherVarName; *p != 0; p++) { - if (*p == '(') { - char *openParen = p; - - do { - p++; - } while (*p != '\0'); - p--; - if (*p != ')') { - goto scalar; - } - *openParen = '\0'; - *p = '\0'; - result = MakeUpvar(iPtr, framePtr, - otherVarName, openParen+1, /*otherFlags*/ 0, - myVarName, /*flags*/ 0); - *openParen = '('; - *p = ')'; - goto checkResult; - } - } - scalar: - result = MakeUpvar(iPtr, framePtr, otherVarName, (char *) NULL, 0, - myVarName, /*flags*/ 0); - - checkResult: + localName = TclGetString(objv[1]); + result = ObjMakeUpvar(interp, framePtr, /* othervarName */ objv[0], + NULL, 0, /* myVarName */ localName, /*flags*/ 0, -1); if (result != TCL_OK) { return TCL_ERROR; } @@ -4035,7 +4006,39 @@ Tcl_UpvarObjCmd(dummy, interp, objc, objv) /* *---------------------------------------------------------------------- * - * CallTraces -- + * DisposeTraceResult-- + * + * This procedure is called to dispose of the result returned from + * a trace procedure. The disposal method appropriate to the type + * of result is determined by flags. + * + * Results: + * None. + * + * Side effects: + * The memory allocated for the trace result may be freed. + * + *---------------------------------------------------------------------- + */ + +void +DisposeTraceResult(flags, result) + int flags; /* Indicates type of result to determine + * proper disposal method */ + char *result; /* The result returned from a trace + * procedure to be disposed */ +{ + if (flags & TCL_TRACE_RESULT_DYNAMIC) { + ckfree(result); + } else if (flags & TCL_TRACE_RESULT_OBJECT) { + Tcl_DecrRefCount((Tcl_Obj *) result); + } +} + +/* + *---------------------------------------------------------------------- + * + * CallVarTraces -- * * This procedure is invoked to find and invoke relevant * trace procedures associated with a particular operation on @@ -4043,12 +4046,11 @@ Tcl_UpvarObjCmd(dummy, interp, objc, objv) * variable and on its containing array (where relevant). * * Results: - * The return value is NULL if no trace procedures were invoked, or - * if all the invoked trace procedures returned successfully. - * The return value is non-NULL if a trace procedure returned an - * error (in this case no more trace procedures were invoked after - * the error was returned). In this case the return value is a - * pointer to a static string describing the error. + * Returns TCL_OK to indicate normal operation. Returns TCL_ERROR + * if invocation of a trace procedure indicated an error. When + * TCL_ERROR is returned and leaveErrMsg is true, then the + * ::errorInfo variable of iPtr has information about the error + * appended to it. * * Side effects: * Almost anything can happen, depending on trace; this procedure @@ -4057,26 +4059,33 @@ Tcl_UpvarObjCmd(dummy, interp, objc, objv) *---------------------------------------------------------------------- */ -static char * -CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) +int +CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg) Interp *iPtr; /* Interpreter containing variable. */ register Var *arrayPtr; /* Pointer to array variable that contains * the variable, or NULL if the variable * isn't an element of an array. */ Var *varPtr; /* Variable whose traces are to be * invoked. */ - char *part1, *part2; /* Variable's two-part name. */ + CONST char *part1; + CONST char *part2; /* Variable's two-part name. */ int flags; /* Flags passed to trace procedures: * indicates what's happening to variable, * plus other stuff like TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, and * TCL_INTERP_DESTROYED. */ + CONST int leaveErrMsg; /* If true, and one of the traces indicates an + * error, then leave an error message and stack + * trace information in *iPTr. */ { register VarTrace *tracePtr; ActiveVarTrace active; - char *result, *openParen, *p; + char *result; + CONST char *openParen, *p; Tcl_DString nameCopy; int copiedName; + int code = TCL_OK; + int disposeFlags = 0; /* * If there are already similar trace procedures active for the @@ -4084,10 +4093,13 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) */ if (varPtr->flags & VAR_TRACE_ACTIVE) { - return NULL; + return code; } varPtr->flags |= VAR_TRACE_ACTIVE; varPtr->refCount++; + if (arrayPtr != NULL) { + arrayPtr->refCount++; + } /* * If the variable name hasn't been parsed into array name and @@ -4108,12 +4120,14 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) } while (*p != '\0'); p--; if (*p == ')') { + int offset = (openParen - part1); + char *newPart1; Tcl_DStringInit(&nameCopy); Tcl_DStringAppend(&nameCopy, part1, (p-part1)); - part2 = Tcl_DStringValue(&nameCopy) - + (openParen + 1 - part1); - part2[-1] = 0; - part1 = Tcl_DStringValue(&nameCopy); + newPart1 = Tcl_DStringValue(&nameCopy); + newPart1[offset] = 0; + part1 = newPart1; + part2 = newPart1 + offset + 1; copiedName = 1; } break; @@ -4126,10 +4140,10 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) */ result = NULL; - active.nextPtr = iPtr->activeTracePtr; - iPtr->activeTracePtr = &active; - if (arrayPtr != NULL) { - arrayPtr->refCount++; + active.nextPtr = iPtr->activeVarTracePtr; + iPtr->activeVarTracePtr = &active; + Tcl_Preserve((ClientData) iPtr); + if (arrayPtr != NULL && !(arrayPtr->flags & VAR_TRACE_ACTIVE)) { active.varPtr = arrayPtr; for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL; tracePtr = active.nextTracePtr) { @@ -4137,15 +4151,22 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) if (!(tracePtr->flags & flags)) { continue; } + Tcl_Preserve((ClientData) tracePtr); result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { if (flags & TCL_TRACE_UNSETS) { - result = NULL; + /* Ignore errors in unset traces */ + DisposeTraceResult(tracePtr->flags, result); } else { - goto done; + disposeFlags = tracePtr->flags; + code = TCL_ERROR; } } + Tcl_Release((ClientData) tracePtr); + if (code == TCL_ERROR) { + goto done; + } } } @@ -4163,15 +4184,22 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) if (!(tracePtr->flags & flags)) { continue; } + Tcl_Preserve((ClientData) tracePtr); result = (*tracePtr->traceProc)(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { if (flags & TCL_TRACE_UNSETS) { - result = NULL; + /* Ignore errors in unset traces */ + DisposeTraceResult(tracePtr->flags, result); } else { - goto done; + disposeFlags = tracePtr->flags; + code = TCL_ERROR; } } + Tcl_Release((ClientData) tracePtr); + if (code == TCL_ERROR) { + goto done; + } } /* @@ -4180,6 +4208,33 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) */ done: + if (code == TCL_ERROR) { + if (leaveErrMsg) { + CONST char *type = ""; + switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) { + case TCL_TRACE_READS: { + type = "read"; + break; + } + case TCL_TRACE_WRITES: { + type = "set"; + break; + } + case TCL_TRACE_ARRAY: { + type = "trace array"; + break; + } + } + if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { + VarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, + Tcl_GetString((Tcl_Obj *) result)); + } else { + VarErrMsg((Tcl_Interp *) iPtr, part1, part2, type, result); + } + } + DisposeTraceResult(disposeFlags,result); + } + if (arrayPtr != NULL) { arrayPtr->refCount--; } @@ -4188,8 +4243,9 @@ CallTraces(iPtr, arrayPtr, varPtr, part1, part2, flags) } varPtr->flags &= ~VAR_TRACE_ACTIVE; varPtr->refCount--; - iPtr->activeTracePtr = active.nextPtr; - return result; + iPtr->activeVarTracePtr = active.nextPtr; + Tcl_Release((ClientData) iPtr); + return code; } /* @@ -4233,9 +4289,75 @@ NewVar() /* *---------------------------------------------------------------------- * + * SetArraySearchObj -- + * + * This function converts the given tcl object into one that + * has the "array search" internal type. + * + * Results: + * TCL_OK if the conversion succeeded, and TCL_ERROR if it failed + * (when an error message will be placed in the interpreter's + * result.) + * + * Side effects: + * Updates the internal type and representation of the object to + * make this an array-search object. See the tclArraySearchType + * declaration above for details of the internal representation. + * + *---------------------------------------------------------------------- + */ + +static int +SetArraySearchObj(interp, objPtr) + Tcl_Interp *interp; + Tcl_Obj *objPtr; +{ + char *string; + char *end; + int id; + size_t offset; + + /* + * Get the string representation. Make it up-to-date if necessary. + */ + + string = Tcl_GetString(objPtr); + + /* + * Parse the id into the three parts separated by dashes. + */ + if ((string[0] != 's') || (string[1] != '-')) { + syntax: + Tcl_AppendResult(interp, "illegal search identifier \"", string, + "\"", (char *) NULL); + return TCL_ERROR; + } + id = strtoul(string+2, &end, 10); + if ((end == (string+2)) || (*end != '-')) { + goto syntax; + } + /* + * Can't perform value check in this context, so place reference + * to place in string to use for the check in the object instead. + */ + end++; + offset = end - string; + + if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) { + objPtr->typePtr->freeIntRepProc(objPtr); + } + objPtr->typePtr = &tclArraySearchType; + objPtr->internalRep.twoPtrValue.ptr1 = (VOID *)(((char *)NULL)+id); + objPtr->internalRep.twoPtrValue.ptr2 = (VOID *)(((char *)NULL)+offset); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * ParseSearchId -- * - * This procedure translates from a string to a pointer to an + * This procedure translates from a tcl object to a pointer to an * active array search (if there is one that matches the string). * * Results: @@ -4244,41 +4366,47 @@ NewVar() * the interp's result contains an error message. * * Side effects: - * None. + * The tcl object might have its internal type and representation + * modified. * *---------------------------------------------------------------------- */ static ArraySearch * -ParseSearchId(interp, varPtr, varName, string) +ParseSearchId(interp, varPtr, varName, handleObj) Tcl_Interp *interp; /* Interpreter containing variable. */ - Var *varPtr; /* Array variable search is for. */ - char *varName; /* Name of array variable that search is + CONST Var *varPtr; /* Array variable search is for. */ + CONST char *varName; /* Name of array variable that search is * supposed to be for. */ - char *string; /* String containing id of search. Must have + Tcl_Obj *handleObj; /* Object containing id of search. Must have * form "search-num-var" where "num" is a * decimal number and "var" is a variable * name. */ { - char *end; + register char *string; + register size_t offset; int id; ArraySearch *searchPtr; /* - * Parse the id into the three parts separated by dashes. + * Parse the id. */ - - if ((string[0] != 's') || (string[1] != '-')) { - syntax: - Tcl_AppendResult(interp, "illegal search identifier \"", string, - "\"", (char *) NULL); + if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) { return NULL; } - id = strtoul(string+2, &end, 10); - if ((end == (string+2)) || (*end != '-')) { - goto syntax; - } - if (strcmp(end+1, varName) != 0) { + /* + * Cast is safe, since always came from an int in the first place. + */ + id = (int)(((char*)handleObj->internalRep.twoPtrValue.ptr1) - + ((char*)NULL)); + string = Tcl_GetString(handleObj); + offset = (((char*)handleObj->internalRep.twoPtrValue.ptr2) - + ((char*)NULL)); + /* + * This test cannot be placed inside the Tcl_Obj machinery, since + * it is dependent on the variable context. + */ + if (strcmp(string+offset, varName) != 0) { Tcl_AppendResult(interp, "search identifier \"", string, "\" isn't for variable \"", varName, "\"", (char *) NULL); return NULL; @@ -4287,6 +4415,10 @@ ParseSearchId(interp, varPtr, varName, string) /* * Search through the list of active searches on the interpreter * to see if the desired one exists. + * + * Note that we cannot store the searchPtr directly in the Tcl_Obj + * as that would run into trouble when DeleteSearches() was called + * so we must scan this list every time. */ for (searchPtr = varPtr->searchPtr; searchPtr != NULL; @@ -4374,10 +4506,13 @@ TclDeleteVars(iPtr, tablePtr) flags = TCL_TRACE_UNSETS; if (tablePtr == &iPtr->globalNsPtr->varTable) { - flags |= (TCL_INTERP_DESTROYED | TCL_GLOBAL_ONLY); + flags |= TCL_GLOBAL_ONLY; } else if (tablePtr == &currNsPtr->varTable) { flags |= TCL_NAMESPACE_ONLY; } + if (Tcl_InterpDeleted(interp)) { + flags |= TCL_INTERP_DESTROYED; + } for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { @@ -4411,7 +4546,7 @@ TclDeleteVars(iPtr, tablePtr) * free up the variable's space (no need to free the hash entry * here, unless we're dealing with a global variable: the * hash entries will be deleted automatically when the whole - * table is deleted). Note that we give CallTraces the variable's + * table is deleted). Note that we give CallVarTraces the variable's * fully-qualified name so that any called trace procedures can * refer to these variables being deleted. */ @@ -4420,16 +4555,16 @@ TclDeleteVars(iPtr, tablePtr) objPtr = Tcl_NewObj(); Tcl_IncrRefCount(objPtr); /* until done with traces */ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); - (void) CallTraces(iPtr, (Var *) NULL, varPtr, - Tcl_GetString(objPtr), (char *) NULL, flags); + CallVarTraces(iPtr, (Var *) NULL, varPtr, Tcl_GetString(objPtr), + NULL, flags, /* leaveErrMsg */ 0); Tcl_DecrRefCount(objPtr); /* free no longer needed obj */ while (varPtr->tracePtr != NULL) { VarTrace *tracePtr = varPtr->tracePtr; varPtr->tracePtr = tracePtr->nextPtr; - ckfree((char *) tracePtr); + Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); } - for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; @@ -4546,14 +4681,14 @@ TclDeleteCompiledLocalVars(iPtr, framePtr) */ if (varPtr->tracePtr != NULL) { - (void) CallTraces(iPtr, (Var *) NULL, varPtr, - varPtr->name, (char *) NULL, flags); + CallVarTraces(iPtr, (Var *) NULL, varPtr, varPtr->name, NULL, + flags, /* leaveErrMsg */ 0); while (varPtr->tracePtr != NULL) { VarTrace *tracePtr = varPtr->tracePtr; varPtr->tracePtr = tracePtr->nextPtr; - ckfree((char *) tracePtr); + Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); } - for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->varPtr == varPtr) { activePtr->nextTracePtr = NULL; @@ -4607,10 +4742,10 @@ TclDeleteCompiledLocalVars(iPtr, framePtr) static void DeleteArray(iPtr, arrayName, varPtr, flags) Interp *iPtr; /* Interpreter containing array. */ - char *arrayName; /* Name of array (used for trace + CONST char *arrayName; /* Name of array (used for trace * callbacks). */ Var *varPtr; /* Pointer to variable structure. */ - int flags; /* Flags to pass to CallTraces: + int flags; /* Flags to pass to CallVarTraces: * TCL_TRACE_UNSETS and sometimes * TCL_INTERP_DESTROYED, * TCL_NAMESPACE_ONLY, or @@ -4634,14 +4769,15 @@ DeleteArray(iPtr, arrayName, varPtr, flags) elPtr->hPtr = NULL; if (elPtr->tracePtr != NULL) { elPtr->flags &= ~VAR_TRACE_ACTIVE; - (void) CallTraces(iPtr, (Var *) NULL, elPtr, arrayName, - Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags); + CallVarTraces(iPtr, (Var *) NULL, elPtr, arrayName, + Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags, + /* leaveErrMsg */ 0); while (elPtr->tracePtr != NULL) { VarTrace *tracePtr = elPtr->tracePtr; elPtr->tracePtr = tracePtr->nextPtr; - ckfree((char *) tracePtr); + Tcl_EventuallyFree((ClientData) tracePtr,TCL_DYNAMIC); } - for (activePtr = iPtr->activeTracePtr; activePtr != NULL; + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->varPtr == elPtr) { activePtr->nextTracePtr = NULL; @@ -4650,6 +4786,19 @@ DeleteArray(iPtr, arrayName, varPtr, flags) } TclSetVarUndefined(elPtr); TclSetVarScalar(elPtr); + + /* + * Even though array elements are not supposed to be namespace + * variables, some combinations of [upvar] and [variable] may + * create such beasts - see [Bug 604239]. This is necessary to + * avoid leaking the corresponding Var struct, and is otherwise + * harmless. + */ + + if (elPtr->flags & VAR_NAMESPACE_VAR) { + elPtr->flags &= ~VAR_NAMESPACE_VAR; + elPtr->refCount--; + } if (elPtr->refCount == 0) { ckfree((char *) elPtr); /* element Vars are VAR_IN_HASHTABLE */ } @@ -4729,10 +4878,11 @@ CleanupVar(varPtr, arrayPtr) static void VarErrMsg(interp, part1, part2, operation, reason) Tcl_Interp *interp; /* Interpreter in which to record message. */ - char *part1, *part2; /* Variable's two-part name. */ - char *operation; /* String describing operation that failed, + CONST char *part1; + CONST char *part2; /* Variable's two-part name. */ + CONST char *operation; /* String describing operation that failed, * e.g. "read", "set", or "unset". */ - char *reason; /* String describing why operation failed. */ + CONST char *reason; /* String describing why operation failed. */ { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "can't ", operation, " \"", part1, @@ -4742,7 +4892,6 @@ VarErrMsg(interp, part1, part2, operation, reason) } Tcl_AppendResult(interp, "\": ", reason, (char *) NULL); } - /* *---------------------------------------------------------------------- @@ -4765,11 +4914,10 @@ VarErrMsg(interp, part1, part2, operation, reason) Var * TclVarTraceExists(interp, varName) Tcl_Interp *interp; /* The interpreter */ - char *varName; /* The variable name */ + CONST char *varName; /* The variable name */ { Var *varPtr; Var *arrayPtr; - char *msg; /* * The choice of "create" flag values is delicate here, and @@ -4782,27 +4930,223 @@ TclVarTraceExists(interp, varName) */ varPtr = TclLookupVar(interp, varName, (char *) NULL, - 0, "access", - /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); + 0, "access", /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { return NULL; } - if ((varPtr != NULL) && - ((varPtr->tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) { - msg = CallTraces((Interp *)interp, arrayPtr, varPtr, varName, - (char *) NULL, TCL_TRACE_READS); - if (msg != NULL) { - /* - * If the variable doesn't exist anymore and no-one's using - * it, then free up the relevant structures and hash table entries. - */ - if (TclIsVarUndefined(varPtr)) { - CleanupVar(varPtr, arrayPtr); + if ((varPtr->tracePtr != NULL) + || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { + CallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL, + TCL_TRACE_READS, /* leaveErrMsg */ 0); + } + + /* + * If the variable doesn't exist anymore and no-one's using + * it, then free up the relevant structures and hash table entries. + */ + + if (TclIsVarUndefined(varPtr)) { + CleanupVar(varPtr, arrayPtr); + return NULL; + } + + return varPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Internal functions for variable name object types -- + * + *---------------------------------------------------------------------- + */ + +/* + * localVarName - + * + * INTERNALREP DEFINITION: + * twoPtrValue.ptr1 = pointer to the corresponding Proc + * twoPtrValue.ptr2 = index into locals table +*/ + +static void +FreeLocalVarName(objPtr) + Tcl_Obj *objPtr; +{ + register Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1; + procPtr->refCount--; + if (procPtr->refCount <= 0) { + TclProcCleanupProc(procPtr); + } +} + +static void +DupLocalVarName(srcPtr, dupPtr) + Tcl_Obj *srcPtr; + Tcl_Obj *dupPtr; +{ + register Proc *procPtr = (Proc *) srcPtr->internalRep.twoPtrValue.ptr1; + + dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr; + dupPtr->internalRep.twoPtrValue.ptr2 = srcPtr->internalRep.twoPtrValue.ptr2; + procPtr->refCount++; + dupPtr->typePtr = &tclLocalVarNameType; +} + +static void +UpdateLocalVarName(objPtr) + Tcl_Obj *objPtr; +{ + Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1; + unsigned int index = (unsigned int) objPtr->internalRep.twoPtrValue.ptr2; + CompiledLocal *localPtr = procPtr->firstLocalPtr; + unsigned int nameLen; + + if (localPtr == NULL) { + goto emptyName; + } + while (index--) { + localPtr = localPtr->nextPtr; + if (localPtr == NULL) { + goto emptyName; + } + } + + nameLen = (unsigned int) localPtr->nameLength; + objPtr->bytes = ckalloc(nameLen + 1); + memcpy(objPtr->bytes, localPtr->name, nameLen + 1); + objPtr->length = nameLen; + return; + + emptyName: + objPtr->bytes = ckalloc(1); + *(objPtr->bytes) = '\0'; + objPtr->length = 0; +} + +/* + * nsVarName - + * + * INTERNALREP DEFINITION: + * twoPtrValue.ptr1: pointer to the namespace containing the + * reference. + * twoPtrValue.ptr2: pointer to the corresponding Var +*/ + +static void +FreeNsVarName(objPtr) + Tcl_Obj *objPtr; +{ + register Var *varPtr = (Var *) objPtr->internalRep.twoPtrValue.ptr2; + + varPtr->refCount--; + if (TclIsVarUndefined(varPtr) && (varPtr->refCount <= 0)) { + if (TclIsVarLink(varPtr)) { + Var *linkPtr = varPtr->value.linkPtr; + linkPtr->refCount--; + if (TclIsVarUndefined(linkPtr) && (linkPtr->refCount <= 0)) { + CleanupVar(linkPtr, (Var *) NULL); } - return NULL; } + CleanupVar(varPtr, NULL); } - return varPtr; +} + +static void +DupNsVarName(srcPtr, dupPtr) + Tcl_Obj *srcPtr; + Tcl_Obj *dupPtr; +{ + Namespace *nsPtr = (Namespace *) srcPtr->internalRep.twoPtrValue.ptr1; + register Var *varPtr = (Var *) srcPtr->internalRep.twoPtrValue.ptr2; + + dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr; + dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr; + varPtr->refCount++; + dupPtr->typePtr = &tclNsVarNameType; +} + +/* + * parsedVarName - + * + * INTERNALREP DEFINITION: + * twoPtrValue.ptr1 = pointer to the array name Tcl_Obj + * (NULL if scalar) + * twoPtrValue.ptr2 = pointer to the element name string + * (owned by this Tcl_Obj), or NULL if + * it is a scalar variable + */ + +static void +FreeParsedVarName(objPtr) + Tcl_Obj *objPtr; +{ + register Tcl_Obj *arrayPtr = + (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1; + register char *elem = (char *) objPtr->internalRep.twoPtrValue.ptr2; + + if (arrayPtr != NULL) { + TclDecrRefCount(arrayPtr); + ckfree(elem); + } +} + +static void +DupParsedVarName(srcPtr, dupPtr) + Tcl_Obj *srcPtr; + Tcl_Obj *dupPtr; +{ + register Tcl_Obj *arrayPtr = + (Tcl_Obj *) srcPtr->internalRep.twoPtrValue.ptr1; + register char *elem = (char *) srcPtr->internalRep.twoPtrValue.ptr2; + char *elemCopy; + unsigned int elemLen; + + if (arrayPtr != NULL) { + Tcl_IncrRefCount(arrayPtr); + elemLen = strlen(elem); + elemCopy = ckalloc(elemLen+1); + memcpy(elemCopy, elem, elemLen); + *(elemCopy + elemLen) = '\0'; + elem = elemCopy; + } + + dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) arrayPtr; + dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) elem; + dupPtr->typePtr = &tclParsedVarNameType; +} + +static void +UpdateParsedVarName(objPtr) + Tcl_Obj *objPtr; +{ + Tcl_Obj *arrayPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1; + char *part2 = (char *) objPtr->internalRep.twoPtrValue.ptr2; + char *part1, *p; + int len1, len2, totalLen; + + if (arrayPtr == NULL) { + /* + * This is a parsed scalar name: what is it + * doing here? + */ + panic("ERROR: scalar parsedVarName without a string rep.\n"); + } + part1 = Tcl_GetStringFromObj(arrayPtr, &len1); + len2 = strlen(part2); + + totalLen = len1 + len2 + 2; + p = ckalloc((unsigned int) totalLen + 1); + objPtr->bytes = p; + objPtr->length = totalLen; + + memcpy(p, part1, (unsigned int) len1); + p += len1; + *p++ = '('; + memcpy(p, part2, (unsigned int) len2); + p += len2; + *p++ = ')'; + *p = '\0'; } |