diff options
Diffstat (limited to 'generic/tclVar.c')
| -rw-r--r-- | generic/tclVar.c | 2327 |
1 files changed, 1550 insertions, 777 deletions
diff --git a/generic/tclVar.c b/generic/tclVar.c index b0036d5..d032cef 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -11,15 +11,97 @@ * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2007 Miguel Sofer * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.144 2007/06/28 13:56:21 msofer Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.145 2007/07/31 17:03:41 msofer Exp $ */ #include "tclInt.h" + /* + * Prototypes for the variable hash key methods. + */ + +static Tcl_HashEntry * AllocVarEntry(Tcl_HashTable *tablePtr, + VOID *keyPtr); +static void FreeVarEntry(Tcl_HashEntry *hPtr); +static int CompareVarKeys(VOID *keyPtr, Tcl_HashEntry *hPtr); +static unsigned int HashVarKey(Tcl_HashTable *tablePtr, VOID *keyPtr); + +Tcl_HashKeyType tclVarHashKeyType = { + TCL_HASH_KEY_TYPE_VERSION, /* version */ + 0, /* flags */ + HashVarKey, /* hashKeyProc */ + CompareVarKeys, /* compareKeysProc */ + AllocVarEntry, /* allocEntryProc */ + FreeVarEntry /* freeEntryProc */ +}; + +static inline Var * VarHashCreateVar(TclVarHashTable *tablePtr, Tcl_Obj *key, int *newPtr); +static inline Var * VarHashFirstVar(TclVarHashTable *tablePtr, Tcl_HashSearch *searchPtr); +static inline Var * VarHashNextVar(Tcl_HashSearch *searchPtr); +static inline void CleanupVar(Var *varPtr, Var *arrayPtr); + +#define VarHashGetValue(hPtr) \ + ((Var *) ((char *)hPtr - offsetof(VarInHash, entry))) + +static inline Var * +VarHashCreateVar(TclVarHashTable *tablePtr, Tcl_Obj *key, int *newPtr) +{ + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr, (char *) key, newPtr); + if (hPtr) { + return VarHashGetValue(hPtr); + } else { + return NULL; + } +} + +#define VarHashFindVar(tablePtr, key) \ + VarHashCreateVar((tablePtr), (key), NULL) + +#define VarHashInvalidateEntry(varPtr) \ + ((varPtr)->flags |= VAR_DEAD_HASH) + +#define VarHashDeleteEntry(varPtr) \ + Tcl_DeleteHashEntry(&(((VarInHash *) varPtr)->entry)) + +#define VarHashFirstEntry(tablePtr, searchPtr) \ + Tcl_FirstHashEntry((Tcl_HashTable *) (tablePtr), (searchPtr)) + +#define VarHashNextEntry(searchPtr) \ + Tcl_NextHashEntry((searchPtr)) + +static inline Var * +VarHashFirstVar(TclVarHashTable *tablePtr, Tcl_HashSearch *searchPtr) +{ + Tcl_HashEntry *hPtr = VarHashFirstEntry(tablePtr, searchPtr); + if (hPtr) { + return VarHashGetValue(hPtr); + } else { + return NULL; + } +} + +static inline Var * +VarHashNextVar(Tcl_HashSearch *searchPtr) +{ + Tcl_HashEntry *hPtr = VarHashNextEntry(searchPtr); + if (hPtr) { + return VarHashGetValue(hPtr); + } else { + return NULL; + } +} + +#define VarHashGetKey(varPtr) \ + (((VarInHash *)(varPtr))->entry.key.objPtr) + +#define VarHashDeleteTable(tablePtr) \ + Tcl_DeleteHashTable((Tcl_HashTable *) (tablePtr)) + /* * The strings below are used to indicate what went wrong when a variable * access is denied. @@ -49,19 +131,20 @@ static const char *isArrayElement = * Forward references to functions defined later in this file: */ -static void DeleteSearches(Var *arrayVarPtr); -static void DeleteArray(Interp *iPtr, const char *arrayName, +static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, + Tcl_Obj *patternPtr, int includeLinks); +static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr); +static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr, Var *varPtr, int flags); static int ObjMakeUpvar(Tcl_Interp *interp, CallFrame *framePtr, Tcl_Obj *otherP1Ptr, const char *otherP2, const int otherFlags, - const char *myName, int myFlags, int index); -static Var * NewVar(void); + Tcl_Obj *myNamePtr, int myFlags, int index); static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr, - const char *varName, Tcl_Obj *handleObj); + Tcl_Obj *varNamePtr, Tcl_Obj *handleObj); static void UnsetVarStruct(Var *varPtr, Var *arrayPtr, - Interp *iPtr, const char *part1, - const char *part2, int flags, int reachable); + Interp *iPtr, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, int flags); static int SetArraySearchObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* @@ -70,10 +153,8 @@ static int SetArraySearchObj(Tcl_Interp *interp, Tcl_Obj *objPtr); */ MODULE_SCOPE Var * TclLookupSimpleVar(Tcl_Interp *interp, - const char *varName, int flags, const int create, + Tcl_Obj *varNamePtr, int flags, const int create, const char **errMsgPtr, int *indexPtr); -MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp, - Tcl_Obj *part1Ptr, const char *part2, int flags); static Tcl_DupInternalRepProc DupLocalVarName; static Tcl_FreeInternalRepProc FreeParsedVarName; @@ -145,6 +226,69 @@ Tcl_ObjType tclArraySearchType = { "array search", NULL, NULL, NULL, SetArraySearchObj }; + + +/* + *---------------------------------------------------------------------- + * + * TclCleanupVar -- + * + * This function is called when it looks like it may be OK to free up a + * variable's storage. If the variable is in a hashtable, its Var + * structure and hash table entry will be freed along with those of its + * containing array, if any. This function is called, for example, when + * a trace on a variable deletes a variable. + * + * Results: + * None. + * + * Side effects: + * If the variable (or its containing array) really is dead and in a + * hashtable, then its Var structure, and possibly its hash table entry, + * is freed up. + * + *---------------------------------------------------------------------- + */ + +static inline void +CleanupVar( + Var *varPtr, /* Pointer to variable that may be a candidate + * for being expunged. */ + Var *arrayPtr) /* Array that contains the variable, or NULL + * if this variable isn't an array element. */ +{ + if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr) + && !TclIsVarTraced(varPtr) + && (VarHashRefCount(varPtr) == !TclIsVarDeadHash(varPtr))) { + if (VarHashRefCount(varPtr) == 0) { + ckfree((char *) varPtr); + } else { + VarHashDeleteEntry(varPtr); + } + } + if (arrayPtr != NULL) { + if (TclIsVarUndefined(arrayPtr) && TclIsVarInHash(arrayPtr) + && !TclIsVarTraced(arrayPtr) + && (VarHashRefCount(arrayPtr) == !TclIsVarDeadHash(arrayPtr))) { + if (VarHashRefCount(arrayPtr) == 0) { + ckfree((char *) arrayPtr); + } else { + VarHashDeleteEntry(arrayPtr); + } + } + } +} + +void +TclCleanupVar( + Var *varPtr, /* Pointer to variable that may be a candidate + * for being expunged. */ + Var *arrayPtr) /* Array that contains the variable, or NULL + * if this variable isn't an array element. */ +{ + return CleanupVar(varPtr, arrayPtr); +} + /* *---------------------------------------------------------------------- @@ -153,8 +297,8 @@ Tcl_ObjType tclArraySearchType = { * * This function 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. + * trace code. It is kept in tcl8.5 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 @@ -208,89 +352,17 @@ TclLookupVar( * address of array variable. Otherwise this * is set to NULL. */ { + Tcl_Obj *part1Ptr; Var *varPtr; - const char *elName; /* Name of array element or NULL; may be same - * as part2, or may be openParen+1. */ - int openParen, closeParen; /* If this function parses a name into 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 = -1; - - /* - * Parse part1 into array name and index. - * Always check if part1 is an array element name and allow it only if - * part2 is not given. (If one does not care about creating array elements - * that can't be used from tcl, and prefer slightly better performance, - * one can put the following in an if (part2 == NULL) { ... } block and - * remove the part2's test and error reporting or move that code in array - * set.) - */ - - elName = part2; - for (p = part1; *p ; p++) { - if (*p == '(') { - openParen = p - part1; - do { - p++; - } while (*p != '\0'); - p--; - if (*p == ')') { - if (part2 != NULL) { - if (flags & TCL_LEAVE_ERR_MSG) { - TclVarErrMsg(interp, part1, part2, msg, needArray); - } - return NULL; - } - closeParen = p - part1; - } else { - 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; - } + part1Ptr = Tcl_NewStringObj(part1, -1); + Tcl_IncrRefCount(part1Ptr); - varPtr = TclLookupSimpleVar(interp, part1, flags, createPart1, - &errMsg, &index); - if (varPtr == NULL) { - if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) { - TclVarErrMsg(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); - } + varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, msg, + createPart1, createPart2, arrayPtrPtr); + TclDecrRefCount(part1Ptr); return varPtr; -#undef VAR_NAME_BUF_SIZE } /* @@ -357,6 +429,36 @@ TclObjLookupVar( * address of array variable. Otherwise this * is set to NULL. */ { + Tcl_Obj *part2Ptr; + Var *resPtr; + + if (part2) { + part2Ptr = Tcl_NewStringObj(part2, -1); + Tcl_IncrRefCount(part2Ptr); + } else { + part2Ptr = NULL; + } + + resPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, + flags, msg, createPart1, createPart2, arrayPtrPtr); + + if (part2Ptr) { + Tcl_DecrRefCount(part2Ptr); + } + + return resPtr; +} + +Var * +TclObjLookupVarEx(Tcl_Interp * interp, + Tcl_Obj * part1Ptr, + Tcl_Obj * part2Ptr, + int flags, + CONST char * msg, + CONST int createPart1, + CONST int createPart2, + Var ** arrayPtrPtr) +{ Interp *iPtr = (Interp *) interp; register Var *varPtr; /* Points to the variable's in-frame Var * structure. */ @@ -368,7 +470,9 @@ TclObjLookupVar( const char *errMsg = NULL; CallFrame *varFramePtr = iPtr->varFramePtr; Namespace *nsPtr; - + char *part2 = part2Ptr? TclGetString(part2Ptr):NULL; + char *newPart2 = NULL; + /* * If part1Ptr is a tclParsedVarNameType, separate it into the pre-parsed * parts. @@ -377,19 +481,22 @@ TclObjLookupVar( *arrayPtrPtr = NULL; if (typePtr == &tclParsedVarNameType) { if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) { - if (part2 != NULL) { + if (part2Ptr != NULL) { /* * ERROR: part1Ptr is already an array element, cannot specify * a part2. */ if (flags & TCL_LEAVE_ERR_MSG) { - part1 = TclGetString(part1Ptr); - TclVarErrMsg(interp, part1, part2, msg, needArray); + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, needArray, -1); } return NULL; } - part2 = part1Ptr->internalRep.twoPtrValue.ptr2; + part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2; + if (newPart2) { + part2Ptr = Tcl_NewStringObj(newPart2, -1); + Tcl_IncrRefCount(part2Ptr); + } part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1; typePtr = part1Ptr->typePtr; } @@ -397,23 +504,34 @@ TclObjLookupVar( } part1 = Tcl_GetStringFromObj(part1Ptr, &len1); - nsPtr = varFramePtr->nsPtr; - if (nsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { + if (varFramePtr) { + nsPtr = varFramePtr->nsPtr; + if (nsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { + goto doParse; + } + } else { + /* + * Some variables in the global ns have to be initialized before the + * root call frame is in place. + */ + + nsPtr = NULL; goto doParse; } if (typePtr == &localVarNameType) { int localIndex = (int) part1Ptr->internalRep.longValue; - + if (HasLocalVars(varFramePtr) && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) && (localIndex < varFramePtr->numCompiledLocals)) { /* * use the cached index if the names coincide. */ - - varPtr = &(varFramePtr->compiledLocals[localIndex]); - if ((varPtr->name != NULL) && (strcmp(part1, varPtr->name) == 0)) { + Tcl_Obj *namePtr = localName(iPtr->varFramePtr, localIndex); + + if (namePtr && (strcmp(part1, TclGetString(namePtr)) == 0)) { + varPtr = (Var *) &(varFramePtr->compiledLocals[localIndex]); goto donePart1; } } @@ -438,14 +556,14 @@ TclObjLookupVar( */ !TclIsVarUndefined(varPtr)))); - if (useReference && (varPtr->hPtr != NULL)) { + if (useReference && !TclIsVarDeadHash(varPtr)) { /* * 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 + * If TclIsVarDeadHash(varPtr), 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 @@ -465,14 +583,13 @@ TclObjLookupVar( */ register int i; - char *newPart2; len2 = -1; for (i = 0; i < len1; i++) { if (*(part1 + i) == '(') { - if (part2 != NULL) { + if (part2Ptr != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { - TclVarErrMsg(interp, part1, part2, msg, needArray); + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, needArray, -1); } } @@ -489,6 +606,8 @@ TclObjLookupVar( memcpy(newPart2, part2, (unsigned int) len2); *(newPart2+len2) = '\0'; part2 = newPart2; + part2Ptr = Tcl_NewStringObj(newPart2, -1); + Tcl_IncrRefCount(part2Ptr); /* * Free the internal rep of the original part1Ptr, now renamed @@ -528,11 +647,14 @@ TclObjLookupVar( TclFreeIntRep(part1Ptr); part1Ptr->typePtr = NULL; - varPtr = TclLookupSimpleVar(interp, part1, flags, createPart1, + varPtr = TclLookupSimpleVar(interp, part1Ptr, flags, createPart1, &errMsg, &index); if (varPtr == NULL) { if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) { - TclVarErrMsg(interp, part1, part2, msg, errMsg); + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, errMsg, -1); + } + if (newPart2) { + Tcl_DecrRefCount(part2Ptr); } return NULL; } @@ -577,8 +699,8 @@ TclObjLookupVar( if (varPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { part1 = TclGetString(part1Ptr); - TclVarErrMsg(interp, part1, part2, msg, - "Cached variable reference is NULL."); + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, + "Cached variable reference is NULL.", -1); } return NULL; } @@ -587,15 +709,17 @@ TclObjLookupVar( varPtr = varPtr->value.linkPtr; } - if (part2 != NULL) { + if (part2Ptr != NULL) { /* * Array element sought: look it up. */ - part1 = TclGetString(part1Ptr); *arrayPtrPtr = varPtr; - varPtr = TclLookupArrayElement(interp, part1, part2, flags, msg, - createPart1, createPart2, varPtr); + varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, flags, msg, + createPart1, createPart2, varPtr, -1); + if (newPart2) { + Tcl_DecrRefCount(part2Ptr); + } } return varPtr; } @@ -659,7 +783,7 @@ TclObjLookupVar( Var * TclLookupSimpleVar( Tcl_Interp *interp, /* Interpreter to use for lookup. */ - const char *varName, /* This is a simple variable name that could + Tcl_Obj *varNamePtr, /* This is a simple variable name that could * represent a scalar or an array. */ int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * LOOKUP_FOR_UPVAR and TCL_LEAVE_ERR_MSG bits @@ -676,15 +800,15 @@ TclLookupSimpleVar( * 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 + TclVarHashTable *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; + const char *varName = TclGetString(varNamePtr); varPtr = NULL; varNsPtr = NULL; /* set non-NULL if a nonlocal variable */ @@ -771,14 +895,12 @@ TclLookupSimpleVar( * otherwise generate our own error! */ - var = Tcl_FindNamespaceVar(interp, varName, (Tcl_Namespace *) cxtNsPtr, + varPtr = (Var *) Tcl_FindNamespaceVar(interp, varName, (Tcl_Namespace *) cxtNsPtr, flags & ~TCL_LEAVE_ERR_MSG); - if (var != (Tcl_Var) NULL) { - varPtr = (Var *) var; - } - if (varPtr == NULL) { + Tcl_Obj *tailPtr; + if (create) { /* var wasn't found so create it */ TclGetNamespaceForQualName(interp, varName, cxtNsPtr, flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); @@ -789,12 +911,12 @@ TclLookupSimpleVar( if (tail == NULL) { *errMsgPtr = missingName; return NULL; + } else if (tail != varName) { + tailPtr = Tcl_NewStringObj(tail, -1); + } else { + tailPtr = varNamePtr; } - hPtr = Tcl_CreateHashEntry(&varNsPtr->varTable, tail, &new); - varPtr = NewVar(); - Tcl_SetHashValue(hPtr, varPtr); - varPtr->hPtr = hPtr; - varPtr->nsPtr = varNsPtr; + varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr, &new); if (lookGlobal) { /* * The variable was created starting from the global @@ -814,50 +936,35 @@ TclLookupSimpleVar( } else { /* local var: look in frame varFramePtr */ Proc *procPtr = varFramePtr->procPtr; int localCt = procPtr->numCompiledLocals; - CompiledLocal *localPtr = procPtr->firstLocalPtr; - Var *localVarPtr = varFramePtr->compiledLocals; - int varNameLen = strlen(varName); - - for (i=0 ; i<localCt ; i++) { - if (!TclIsVarTemporary(localPtr)) { - register char *localName = localVarPtr->name; + Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0; + + for (i=0 ; i<localCt ; i++, objPtrPtr++) { + Tcl_Obj *objPtr = *objPtrPtr; + if (objPtr) { + char *localName = TclGetString(objPtr); if ((varName[0] == localName[0]) - && (varNameLen == localPtr->nameLength) && (strcmp(varName, localName) == 0)) { *indexPtr = i; - return localVarPtr; + return (Var *) &varFramePtr->compiledLocals[i]; } } - localVarPtr++; - localPtr = localPtr->nextPtr; } tablePtr = varFramePtr->varTablePtr; if (create) { if (tablePtr == NULL) { - tablePtr = (Tcl_HashTable *) - ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS); + tablePtr = (TclVarHashTable *) ckalloc(sizeof(TclVarHashTable)); + TclInitVarHashTable(tablePtr, NULL); 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 { - varPtr = (Var *) Tcl_GetHashValue(hPtr); - } + varPtr = VarHashCreateVar(tablePtr, varNamePtr, &new); } else { - hPtr = NULL; + varPtr = NULL; if (tablePtr != NULL) { - hPtr = Tcl_FindHashEntry(tablePtr, varName); + varPtr = VarHashFindVar(tablePtr, varNamePtr); } - if (hPtr == NULL) { + if (varPtr == NULL) { *errMsgPtr = noSuchVar; - return NULL; } - varPtr = (Var *) Tcl_GetHashValue(hPtr); } } return varPtr; @@ -903,8 +1010,9 @@ TclLookupSimpleVar( Var * TclLookupArrayElement( 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. */ + Tcl_Obj *arrayNamePtr, /* This is the name of the array, or NULL if + * index>= 0. */ + Tcl_Obj *elNamePtr, /* 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 @@ -916,11 +1024,13 @@ TclLookupArrayElement( 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. */ + Var *arrayPtr, /* Pointer to the array's Var structure. */ + int index) /* If >=0, the index of the local array. */ { - Tcl_HashEntry *hPtr; int new; Var *varPtr; + TclVarHashTable *tablePtr; + Namespace *nsPtr; /* * We're dealing with an array element. Make sure the variable is an array @@ -930,7 +1040,7 @@ TclLookupArrayElement( if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) { if (!createArray) { if (flags & TCL_LEAVE_ERR_MSG) { - TclVarErrMsg(interp, arrayName, elName, msg, noSuchVar); + TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, noSuchVar, index); } return NULL; } @@ -940,49 +1050,49 @@ TclLookupArrayElement( * deleted namespace! */ - if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) { + if (TclIsVarDeadHash(arrayPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { - TclVarErrMsg(interp, arrayName, elName, msg, danglingVar); + TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, danglingVar, index); } return NULL; } TclSetVarArray(arrayPtr); - TclClearVarUndefined(arrayPtr); - arrayPtr->value.tablePtr = (Tcl_HashTable *) - ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS); + tablePtr = (TclVarHashTable *) ckalloc(sizeof(TclVarHashTable)); + arrayPtr->value.tablePtr = tablePtr; + + if (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr)) { + nsPtr = TclGetVarNsPtr(arrayPtr); + } else { + nsPtr = NULL; + } + TclInitVarHashTable(arrayPtr->value.tablePtr, nsPtr); } else if (!TclIsVarArray(arrayPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { - TclVarErrMsg(interp, arrayName, elName, msg, needArray); + TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, needArray, index); } return NULL; } if (createElem) { - hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elName, &new); + varPtr = VarHashCreateVar(arrayPtr->value.tablePtr, elNamePtr, &new); if (new) { - if (arrayPtr->searchPtr != NULL) { - DeleteSearches(arrayPtr); + if (arrayPtr->flags & VAR_SEARCH_ACTIVE) { + DeleteSearches((Interp *) interp, arrayPtr); } - varPtr = NewVar(); - Tcl_SetHashValue(hPtr, varPtr); - varPtr->hPtr = hPtr; - varPtr->nsPtr = arrayPtr->nsPtr; TclSetVarArrayElement(varPtr); } } else { - hPtr = Tcl_FindHashEntry(arrayPtr->value.tablePtr, elName); - if (hPtr == NULL) { + varPtr = VarHashFindVar(arrayPtr->value.tablePtr, elNamePtr); + if (varPtr == NULL) { if (flags & TCL_LEAVE_ERR_MSG) { - TclVarErrMsg(interp, arrayName, elName, msg, noSuchElement); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", elName, + TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, noSuchElement, index); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ELEMENT", TclGetString(elNamePtr), NULL); } - return NULL; } } - return (Var *) Tcl_GetHashValue(hPtr); + return varPtr; } /* @@ -1097,17 +1207,25 @@ Tcl_GetVar2Ex( int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ { - Var *varPtr, *arrayPtr; + Tcl_Obj *part1Ptr, *part2Ptr, *resPtr; - /* Filter to pass through only the flags this interface supports. */ - flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG); - varPtr = TclLookupVar(interp, part1, part2, flags, "read", - /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); - if (varPtr == NULL) { - return NULL; + part1Ptr = Tcl_NewStringObj(part1, -1); + Tcl_IncrRefCount(part1Ptr); + if (part2) { + part2Ptr = Tcl_NewStringObj(part2, -1); + Tcl_IncrRefCount(part2Ptr); + } else { + part2Ptr = NULL; } + + resPtr = Tcl_ObjGetVar2(interp, part1Ptr, part2Ptr, flags); - return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags); + Tcl_DecrRefCount(part1Ptr); + if (part2Ptr) { + Tcl_DecrRefCount(part2Ptr); + } + + return resPtr; } /* @@ -1147,20 +1265,16 @@ Tcl_ObjGetVar2( * TCL_LEAVE_ERR_MSG bits. */ { Var *varPtr, *arrayPtr; - char *part1, *part2; - - part1 = TclGetString(part1Ptr); - part2 = ((part2Ptr == NULL) ? NULL : TclGetString(part2Ptr)); /* Filter to pass through only the flags this interface supports. */ flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG); - varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read", + varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "read", /*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return NULL; } - return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags); + return TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, flags, -1); } /* @@ -1192,25 +1306,27 @@ TclPtrGetVar( 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 + Tcl_Obj *part1Ptr, /* 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 + Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ - const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and + const int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ + int index) { Interp *iPtr = (Interp *) interp; const char *msg; /* - * Invoke any traces that have been set for the variable. + * Invoke any read traces that have been set for the variable. */ - if ((varPtr->tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, + if ((varPtr->flags & VAR_TRACED_READ) + || (arrayPtr && (arrayPtr->flags & VAR_TRACED_READ))) { + if (TCL_ERROR == TclObjCallVarTraces(iPtr, arrayPtr, varPtr, + part1Ptr, part2Ptr, (flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY)) - | TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { + | TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG), index)) { goto errorReturn; } } @@ -1224,7 +1340,7 @@ TclPtrGetVar( } if (flags & TCL_LEAVE_ERR_MSG) { - if (TclIsVarUndefined(varPtr) && (arrayPtr != NULL) + if (TclIsVarUndefined(varPtr) && arrayPtr && !TclIsVarUndefined(arrayPtr)) { msg = noSuchElement; } else if (TclIsVarArray(varPtr)) { @@ -1232,7 +1348,7 @@ TclPtrGetVar( } else { msg = noSuchVar; } - TclVarErrMsg(interp, part1, part2, "read", msg); + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "read", msg, index); } /* @@ -1443,22 +1559,25 @@ Tcl_SetVar2Ex( * TCL_APPEND_VALUE, TCL_LIST_ELEMENT or * TCL_LEAVE_ERR_MSG. */ { - Var *varPtr, *arrayPtr; + Tcl_Obj *part1Ptr, *part2Ptr, *resPtr; - /* Filter to pass through only the flags this interface supports. */ - flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG - |TCL_APPEND_VALUE|TCL_LIST_ELEMENT); - varPtr = TclLookupVar(interp, part1, part2, flags, "set", - /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); - if (varPtr == NULL) { - if (newValuePtr->refCount == 0) { - Tcl_DecrRefCount(newValuePtr); - } - return NULL; + part1Ptr = Tcl_NewStringObj(part1, -1); + Tcl_IncrRefCount(part1Ptr); + if (part2) { + part2Ptr = Tcl_NewStringObj(part2, -1); + Tcl_IncrRefCount(part2Ptr); + } else { + part2Ptr = NULL; } + + resPtr = Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags); - return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, - newValuePtr, flags); + Tcl_DecrRefCount(part1Ptr); + if (part2Ptr) { + Tcl_DecrRefCount(part2Ptr); + } + + return resPtr; } /* @@ -1502,15 +1621,10 @@ Tcl_ObjSetVar2( * TCL_LEAVE_ERR_MSG. */ { Var *varPtr, *arrayPtr; - char *part1, *part2; - - part1 = TclGetString(part1Ptr); - part2 = ((part2Ptr == NULL) ? NULL : TclGetString(part2Ptr)); - /* Filter to pass through only the flags this interface supports. */ flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG |TCL_APPEND_VALUE|TCL_LIST_ELEMENT); - varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "set", + varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { if (newValuePtr->refCount == 0) { @@ -1519,8 +1633,8 @@ Tcl_ObjSetVar2( return NULL; } - return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, - newValuePtr, flags); + return TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + newValuePtr, flags, -1); } /* @@ -1556,18 +1670,20 @@ TclPtrSetVar( Var *arrayPtr, /* Reference to the array containing the * variable, or NULL if the variable is a * scalar. */ - 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 + Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or + * the name of a variable. NULL if index >= 0*/ + Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ Tcl_Obj *newValuePtr, /* New value for variable. */ - const int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, and + const int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and * TCL_LEAVE_ERR_MSG bits. */ + int index) /* index of local var where part1 is to be + * found. */ { Interp *iPtr = (Interp *) interp; Tcl_Obj *oldValuePtr; Tcl_Obj *resultPtr = NULL; - int result; + int result; /* * If the variable is in a hashtable and its hPtr field is NULL, then we @@ -1577,12 +1693,12 @@ TclPtrSetVar( * allocation and is meaningless anyway). */ - if ((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) { + if (TclIsVarDeadHash(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarArrayElement(varPtr)) { - TclVarErrMsg(interp, part1, part2, "set", danglingElement); + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", danglingElement, index); } else { - TclVarErrMsg(interp, part1, part2, "set", danglingVar); + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", danglingVar, index); } } goto earlyError; @@ -1592,9 +1708,9 @@ TclPtrSetVar( * It's an error to try to set an array variable itself. */ - if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { + if (TclIsVarArray(varPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { - TclVarErrMsg(interp, part1, part2, "set", isArray); + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", isArray, index); } goto earlyError; } @@ -1605,10 +1721,11 @@ TclPtrSetVar( * instructions. */ - if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) { - if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, - TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) { + if ((flags & TCL_TRACE_READS) && ((varPtr->flags & VAR_TRACED_READ) + || (arrayPtr && (arrayPtr->flags & VAR_TRACED_READ)))) { + if (TCL_ERROR == TclObjCallVarTraces(iPtr, arrayPtr, varPtr, + part1Ptr, part2Ptr, + TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG), index)) { goto earlyError; } } @@ -1620,16 +1737,22 @@ TclPtrSetVar( * otherwise we must create a new copy to modify: this is "copy on write". */ + oldValuePtr = varPtr->value.objPtr; if (flags & TCL_LIST_ELEMENT && !(flags & TCL_APPEND_VALUE)) { - TclSetVarUndefined(varPtr); + varPtr->value.objPtr = NULL; } - oldValuePtr = varPtr->value.objPtr; if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) { +#if 0 + /* + * Can't happen now! + */ + if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) { TclDecrRefCount(oldValuePtr); /* discard old value */ varPtr->value.objPtr = NULL; oldValuePtr = NULL; } +#endif if (flags & TCL_LIST_ELEMENT) { /* append list element */ if (oldValuePtr == NULL) { TclNewObj(oldValuePtr); @@ -1641,8 +1764,7 @@ TclPtrSetVar( oldValuePtr = varPtr->value.objPtr; Tcl_IncrRefCount(oldValuePtr); /* since var is referenced */ } - result = Tcl_ListObjAppendElement(interp, oldValuePtr, - newValuePtr); + result = Tcl_ListObjAppendElement(interp, oldValuePtr, newValuePtr); if (result != TCL_OK) { goto earlyError; } @@ -1681,21 +1803,17 @@ TclPtrSetVar( TclDecrRefCount(oldValuePtr); /* discard old value */ } } - TclSetVarScalar(varPtr); - TclClearVarUndefined(varPtr); - if (arrayPtr != NULL) { - TclClearVarUndefined(arrayPtr); - } - + /* * Invoke any write traces for the variable. */ - if ((varPtr->tracePtr != NULL) - || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) { - if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) - | TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) { + if ((varPtr->flags & VAR_TRACED_WRITE) + || (arrayPtr && (arrayPtr->flags & VAR_TRACED_WRITE))) { + if (TCL_ERROR == TclObjCallVarTraces(iPtr, arrayPtr, varPtr, + part1Ptr, part2Ptr, + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))|TCL_TRACE_WRITES, + (flags & TCL_LEAVE_ERR_MSG), index)) { goto cleanup; } } @@ -1778,20 +1896,16 @@ TclIncrObjVar2( * TCL_LEAVE_ERR_MSG. */ { Var *varPtr, *arrayPtr; - char *part1, *part2; - - part1 = TclGetString(part1Ptr); - part2 = ((part2Ptr == NULL)? NULL : TclGetString(part2Ptr)); - varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read", + varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "read", 1, 1, &arrayPtr); if (varPtr == NULL) { Tcl_AddObjErrorInfo(interp, "\n (reading value of variable to increment)", -1); return NULL; } - return TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1, part2, - incrPtr, flags); + return TclPtrIncrObjVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + incrPtr, flags, -1); } /* @@ -1827,25 +1941,30 @@ TclPtrIncrObjVar( Var *arrayPtr, /* Reference to the array containing the * variable, or NULL if the variable is a * scalar. */ - const char *part1, /* Points to an object holding the name of an + Tcl_Obj *part1Ptr, /* 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 + Tcl_Obj *part2Ptr, /* If non-null, points to an object holding * the name of an element in the array * part1Ptr. */ Tcl_Obj *incrPtr, /* Increment value */ /* TODO: Which of these flag values really make sense? */ - const int flags) /* Various flags that tell how to incr value: + 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. */ + int index) { register Tcl_Obj *varValuePtr, *newValuePtr = NULL; int duplicated, code; - - varPtr->refCount++; - varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags); - varPtr->refCount--; + + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)++; + } + varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, flags, index); + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)--; + } if (varValuePtr == NULL) { varValuePtr = Tcl_NewIntObj(0); } @@ -1857,8 +1976,8 @@ TclPtrIncrObjVar( } code = TclIncrObj(interp, varValuePtr, incrPtr); if (code == TCL_OK) { - newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, - varValuePtr, flags); + newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, + varValuePtr, flags, index); } else if (duplicated) { Tcl_DecrRefCount(varValuePtr); } @@ -1931,15 +2050,23 @@ Tcl_UnsetVar2( * TCL_LEAVE_ERR_MSG. */ { int result; - Tcl_Obj *part1Ptr; + Tcl_Obj *part1Ptr, *part2Ptr = NULL; part1Ptr = Tcl_NewStringObj(part1, -1); Tcl_IncrRefCount(part1Ptr); + if (part2) { + part2Ptr = Tcl_NewStringObj(part2, -1); + Tcl_IncrRefCount(part2Ptr); + } + /* Filter to pass through only the flags this interface supports. */ flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG); - result = TclObjUnsetVar2(interp, part1Ptr, part2, flags); - TclDecrRefCount(part1Ptr); + result = TclObjUnsetVar2(interp, part1Ptr, part2Ptr, flags); + Tcl_DecrRefCount(part1Ptr); + if (part2Ptr) { + Tcl_DecrRefCount(part2Ptr); + } return result; } @@ -1969,7 +2096,7 @@ TclObjUnsetVar2( 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. */ + Tcl_Obj *part2Ptr, /* 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. */ @@ -1978,10 +2105,8 @@ TclObjUnsetVar2( Interp *iPtr = (Interp *) interp; Var *arrayPtr; int result; - char *part1; - part1 = TclGetString(part1Ptr); - varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "unset", + varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "unset", /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; @@ -1996,9 +2121,11 @@ TclObjUnsetVar2( * the variable's name. */ - varPtr->refCount++; + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)++; + } - UnsetVarStruct(varPtr, arrayPtr, iPtr, part1, part2, flags, 1); + UnsetVarStruct(varPtr, arrayPtr, iPtr, part1Ptr, part2Ptr, flags); /* * It's an error to unset an undefined variable. @@ -2006,8 +2133,8 @@ TclObjUnsetVar2( if (result != TCL_OK) { if (flags & TCL_LEAVE_ERR_MSG) { - TclVarErrMsg(interp, part1, part2, "unset", - ((arrayPtr == NULL) ? noSuchVar : noSuchElement)); + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", + ((arrayPtr == NULL) ? noSuchVar : noSuchElement), -1); } } @@ -2030,8 +2157,10 @@ TclObjUnsetVar2( * its value object, if any, was decremented above. */ - varPtr->refCount--; - TclCleanupVar(varPtr, arrayPtr); + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)--; + CleanupVar(varPtr, arrayPtr); + } return result; } @@ -2059,23 +2188,21 @@ UnsetVarStruct( Var *varPtr, Var *arrayPtr, Interp *iPtr, - const char *part1, /* NULL if it is to be computed on demand, only for - * variables in a hashtable */ - const char *part2, - int flags, - int reachable) /* indicates if the variable is accessible by name */ + Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, + int flags) { Var dummyVar; - Var *dummyVarPtr; - ActiveVarTrace *activePtr; - Tcl_Obj *part1Ptr = NULL; - int traced = !TclIsVarUntraced(varPtr) - || (arrayPtr && !TclIsVarUntraced(arrayPtr)); - - if (arrayPtr && arrayPtr->searchPtr) { - DeleteSearches(arrayPtr); + int traced = TclIsVarTraced(varPtr) + || (arrayPtr && (arrayPtr->flags & VAR_TRACED_UNSET)); + + if (arrayPtr && (arrayPtr->flags & VAR_SEARCH_ACTIVE)) { + DeleteSearches(iPtr, arrayPtr); + } else if (varPtr->flags & VAR_SEARCH_ACTIVE) { + DeleteSearches(iPtr, varPtr); } + /* * The code below is tricky, because of the possibility that a trace * function might try to access a variable being deleted. To handle this @@ -2088,18 +2215,10 @@ UnsetVarStruct( * gotten recreated by a trace). */ - if (reachable && (traced || TclIsVarArray(varPtr))) { - dummyVar = *varPtr; - dummyVarPtr = &dummyVar; - TclSetVarUndefined(varPtr); - TclSetVarScalar(varPtr); - varPtr->value.objPtr = NULL; /* dummyVar points to any value object */ - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - } else { - dummyVarPtr = varPtr; - } - + dummyVar = *varPtr; + dummyVar.flags &= ~VAR_ALL_HASH; + TclSetVarUndefined(varPtr); + /* * Call trace functions for the variable being deleted. Then delete its * traces. Be sure to abort any other traces for the variable that are @@ -2111,65 +2230,67 @@ UnsetVarStruct( */ if (traced) { - /* - * Get the variable's name if NULL was passed; - */ + VarTrace *tracePtr = NULL; + Tcl_HashEntry *tPtr = NULL; - if (part1 == NULL) { - Tcl_Interp *interp = (Tcl_Interp *) iPtr; - TclNewObj(part1Ptr); - Tcl_IncrRefCount(part1Ptr); - Tcl_GetVariableFullName(interp, (Tcl_Var) dummyVarPtr, part1Ptr); - part1 = TclGetString(part1Ptr); + if (TclIsVarTraced(&dummyVar)) { + /* + * Transfer any existing traces on var, IF there are unset + * traces. Otherwise just delete them. + */ + + int new; + Tcl_HashEntry *tPtr = + Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); + + tracePtr = Tcl_GetHashValue(tPtr); + varPtr->flags &= ~VAR_ALL_TRACES; + Tcl_DeleteHashEntry(tPtr); + if (dummyVar.flags & VAR_TRACED_UNSET) { + tPtr = Tcl_CreateHashEntry(&iPtr->varTraces, (char *) &dummyVar, &new); + Tcl_SetHashValue(tPtr, tracePtr); + } else { + tPtr = NULL; + } } - - dummyVarPtr->flags &= ~VAR_TRACE_ACTIVE; - TclCallVarTraces(iPtr, arrayPtr, dummyVarPtr, part1, part2, (flags - & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) - | TCL_TRACE_UNSETS, /* leaveErrMsg */ 0); - while (dummyVarPtr->tracePtr != NULL) { - VarTrace *tracePtr = dummyVarPtr->tracePtr; - dummyVarPtr->tracePtr = tracePtr->nextPtr; - Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); - } - for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { - if (activePtr->varPtr == varPtr) { - activePtr->nextTracePtr = NULL; + + if ((dummyVar.flags & VAR_TRACED_UNSET) || (arrayPtr->flags & VAR_TRACED_UNSET)) { + dummyVar.flags &= ~VAR_TRACE_ACTIVE; + TclObjCallVarTraces(iPtr, arrayPtr, (Var *) &dummyVar, part1Ptr, part2Ptr, + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))| TCL_TRACE_UNSETS, + /* leaveErrMsg */ 0, -1); + if (tPtr) { + Tcl_DeleteHashEntry(tPtr); } } - if (part1Ptr) { - Tcl_DecrRefCount(part1Ptr); - part1 = NULL; + + if (tracePtr) { + ActiveVarTrace *activePtr; + + while (tracePtr) { + VarTrace *prevPtr = tracePtr; + tracePtr = tracePtr->nextPtr; + Tcl_EventuallyFree((ClientData) prevPtr, TCL_DYNAMIC); + } + for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; + activePtr = activePtr->nextPtr) { + if (activePtr->varPtr == varPtr) { + activePtr->nextTracePtr = NULL; + } + } + dummyVar.flags &= ~VAR_ALL_TRACES; } } + - if (TclIsVarScalar(dummyVarPtr) - && (dummyVarPtr->value.objPtr != NULL)) { + if (TclIsVarScalar(&dummyVar) && (dummyVar.value.objPtr != NULL)) { /* * Decrement the ref count of the var's value */ - Tcl_Obj *objPtr = dummyVarPtr->value.objPtr; + Tcl_Obj *objPtr = dummyVar.value.objPtr; TclDecrRefCount(objPtr); - dummyVarPtr->value.objPtr = NULL; - } else if (TclIsVarLink(varPtr)) { - /* - * For global/upvar variables referenced in procedures, decrement the - * reference count on the variable referred to, and free the - * referenced variable if it's no longer needed. - */ - Var *linkPtr = varPtr->value.linkPtr; - linkPtr->refCount--; - if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr) - && (linkPtr->tracePtr == NULL) - && (linkPtr->flags & VAR_IN_HASHTABLE)) { - if (linkPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(linkPtr->hPtr); - } - ckfree((char *) linkPtr); - } - } else if (TclIsVarArray(dummyVarPtr) && !TclIsVarUndefined(dummyVarPtr)) { + } else if (TclIsVarArray(&dummyVar)) { /* * If the variable is an array, delete all of its elements. This must * be done after calling and deleting the traces on the array, above @@ -2178,25 +2299,28 @@ UnsetVarStruct( * computed at DeleteArray. */ - DeleteArray(iPtr, part1, dummyVarPtr, (flags + DeleteArray(iPtr, part1Ptr, (Var *) &dummyVar, (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS); + } else if (TclIsVarLink(&dummyVar)) { + /* + * For global/upvar variables referenced in procedures, decrement the + * reference count on the variable referred to, and free the + * referenced variable if it's no longer needed. + */ + Var *linkPtr = dummyVar.value.linkPtr; + if (TclIsVarInHash(linkPtr)) { + VarHashRefCount(linkPtr)--; + CleanupVar(linkPtr, NULL); + } } - if (dummyVarPtr == varPtr) { - TclSetVarUndefined(varPtr); - TclSetVarScalar(varPtr); - } - /* * If the variable was a namespace variable, decrement its reference * count. */ - if (TclIsVarNamespaceVar(varPtr)) { - TclClearVarNamespaceVar(varPtr); - varPtr->refCount--; - } + TclClearVarNamespaceVar(varPtr); } /* @@ -2293,8 +2417,6 @@ Tcl_AppendObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Var *varPtr, *arrayPtr; - char *part1; - register Tcl_Obj *varValuePtr = NULL; /* Initialized to avoid compiler warning. */ int i; @@ -2310,9 +2432,8 @@ Tcl_AppendObjCmd( return TCL_ERROR; } } else { - varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG, + varPtr = TclObjLookupVarEx(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG, "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); - part1 = TclGetString(objv[1]); if (varPtr == NULL) { return TCL_ERROR; } @@ -2324,8 +2445,8 @@ Tcl_AppendObjCmd( * variable again. */ - varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL, - objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG)); + varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, objv[1], NULL, + objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG), -1); if (varValuePtr == NULL) { return TCL_ERROR; } @@ -2363,7 +2484,6 @@ Tcl_LappendObjCmd( Tcl_Obj *varValuePtr, *newValuePtr; int numElems, createdNewObj; Var *varPtr, *arrayPtr; - char *part1; int result; if (objc < 2) { @@ -2409,21 +2529,24 @@ Tcl_LappendObjCmd( * and unused. */ - varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG, + varPtr = TclObjLookupVarEx(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++; + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)++; } - part1 = TclGetString(objv[1]); - varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, NULL, - TCL_LEAVE_ERR_MSG); - varPtr->refCount--; - if (arrayPtr != NULL) { - arrayPtr->refCount--; + if (arrayPtr && TclIsVarInHash(arrayPtr)) { + VarHashRefCount(arrayPtr)++; + } + varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, objv[1], NULL, + TCL_LEAVE_ERR_MSG, -1); + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)--; + } + if (arrayPtr && TclIsVarInHash(arrayPtr)) { + VarHashRefCount(arrayPtr)--; } if (varValuePtr == NULL) { @@ -2458,8 +2581,8 @@ Tcl_LappendObjCmd( * and we didn't create the variable. */ - newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL, - varValuePtr, TCL_LEAVE_ERR_MSG); + newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, objv[1], NULL, + varValuePtr, TCL_LEAVE_ERR_MSG, -1); if (newValuePtr == NULL) { return TCL_ERROR; } @@ -2519,7 +2642,6 @@ Tcl_ArrayObjCmd( Tcl_HashEntry *hPtr; Tcl_Obj *varNamePtr; int notArray; - char *varName; int index, result; if (objc < 3) { @@ -2537,8 +2659,7 @@ Tcl_ArrayObjCmd( */ varNamePtr = objv[2]; - varName = TclGetString(varNamePtr); - varPtr = TclObjLookupVar(interp, varNamePtr, NULL, /*flags*/ 0, + varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); /* @@ -2546,11 +2667,11 @@ Tcl_ArrayObjCmd( * array get, etc. */ - if (varPtr != NULL && varPtr->tracePtr != NULL + if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TCL_ERROR == TclCallVarTraces(iPtr, arrayPtr, varPtr, varName, + if (TCL_ERROR == TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNamePtr, NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1)) { + TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1)) { return TCL_ERROR; } } @@ -2578,7 +2699,7 @@ Tcl_ArrayObjCmd( if (notArray) { goto error; } - searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); + searchPtr = ParseSearchId(interp, varPtr, varNamePtr, objv[3]); if (searchPtr == NULL) { return TCL_ERROR; } @@ -2586,7 +2707,7 @@ Tcl_ArrayObjCmd( Var *varPtr2; if (searchPtr->nextEntry != NULL) { - varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry); + varPtr2 = VarHashGetValue(searchPtr->nextEntry); if (!TclIsVarUndefined(varPtr2)) { break; } @@ -2610,14 +2731,20 @@ Tcl_ArrayObjCmd( if (notArray) { goto error; } - searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); + searchPtr = ParseSearchId(interp, varPtr, varNamePtr, objv[3]); if (searchPtr == NULL) { return TCL_ERROR; } - if (varPtr->searchPtr == searchPtr) { - varPtr->searchPtr = searchPtr->nextPtr; + hPtr = Tcl_FindHashEntry(&iPtr->varSearches,(char *) varPtr); + if (searchPtr == Tcl_GetHashValue(hPtr)) { + if (searchPtr->nextPtr) { + Tcl_SetHashValue(hPtr, searchPtr->nextPtr); + } else { + varPtr->flags &= ~VAR_SEARCH_ACTIVE; + Tcl_DeleteHashEntry(hPtr); + } } else { - for (prevPtr=varPtr->searchPtr ;; prevPtr=prevPtr->nextPtr) { + for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) { if (prevPtr->nextPtr == searchPtr) { prevPtr->nextPtr = searchPtr->nextPtr; break; @@ -2630,6 +2757,7 @@ Tcl_ArrayObjCmd( case ARRAY_NEXTELEMENT: { ArraySearch *searchPtr; Tcl_HashEntry *hPtr; + Var *varPtr2; if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName searchId"); @@ -2638,13 +2766,11 @@ Tcl_ArrayObjCmd( if (notArray) { goto error; } - searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]); + searchPtr = ParseSearchId(interp, varPtr, varNamePtr, objv[3]); if (searchPtr == NULL) { return TCL_ERROR; } while (1) { - Var *varPtr2; - hPtr = searchPtr->nextEntry; if (hPtr == NULL) { hPtr = Tcl_NextHashEntry(&searchPtr->search); @@ -2654,17 +2780,19 @@ Tcl_ArrayObjCmd( } else { searchPtr->nextEntry = NULL; } - varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + varPtr2 = VarHashGetValue(hPtr); if (!TclIsVarUndefined(varPtr2)) { break; } } - Tcl_SetObjResult(interp, Tcl_NewStringObj( - Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1)); + Tcl_SetObjResult(interp, VarHashGetKey(varPtr2)); break; } case ARRAY_STARTSEARCH: { ArraySearch *searchPtr; + int new; + char *varName = TclGetString(varNamePtr); + if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); @@ -2674,21 +2802,25 @@ Tcl_ArrayObjCmd( goto error; } searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch)); - if (varPtr->searchPtr == NULL) { + hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, + (char *) varPtr, &new); + if (new) { searchPtr->id = 1; Tcl_AppendResult(interp, "s-1-", varName, NULL); + varPtr->flags |= VAR_SEARCH_ACTIVE; + searchPtr->nextPtr = NULL; } else { char string[TCL_INTEGER_SPACE]; - searchPtr->id = varPtr->searchPtr->id + 1; + searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1; TclFormatInt(string, searchPtr->id); Tcl_AppendResult(interp, "s-", string, "-", varName, NULL); + searchPtr->nextPtr = Tcl_GetHashValue(hPtr); } searchPtr->varPtr = varPtr; - searchPtr->nextEntry = Tcl_FirstHashEntry(varPtr->value.tablePtr, + searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, &searchPtr->search); - searchPtr->nextPtr = varPtr->searchPtr; - varPtr->searchPtr = searchPtr; + Tcl_SetHashValue(hPtr, searchPtr); break; } @@ -2725,37 +2857,34 @@ Tcl_ArrayObjCmd( TclNewObj(nameLstPtr); Tcl_IncrRefCount(nameLstPtr); if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { - hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, pattern); - if (hPtr == NULL) { + varPtr2 = VarHashFindVar(varPtr->value.tablePtr, objv[3]); + if (varPtr2 == NULL) { goto searchDone; } - varPtr2 = (Var *) Tcl_GetHashValue(hPtr); if (TclIsVarUndefined(varPtr2)) { goto searchDone; } result = Tcl_ListObjAppendElement(interp, nameLstPtr, - Tcl_NewStringObj(pattern, -1)); + VarHashGetKey(varPtr2)); if (result != TCL_OK) { TclDecrRefCount(nameLstPtr); return result; } goto searchDone; } - for (hPtr=Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) { - varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + for (varPtr2 = VarHashFirstVar(varPtr->value.tablePtr, &search); + varPtr2; varPtr2 = VarHashNextVar(&search)) { if (TclIsVarUndefined(varPtr2)) { continue; } - name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + namePtr = VarHashGetKey(varPtr2); + name = TclGetString(namePtr); if ((objc == 4) && !Tcl_StringMatch(name, pattern)) { continue; /* element name doesn't match pattern */ } - namePtr = Tcl_NewStringObj(name, -1); result = Tcl_ListObjAppendElement(interp, nameLstPtr, namePtr); if (result != TCL_OK) { - TclDecrRefCount(namePtr); /* free unneeded name obj */ TclDecrRefCount(nameLstPtr); return result; } @@ -2767,23 +2896,23 @@ Tcl_ArrayObjCmd( * while we're working. */ - varPtr->refCount++; + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)++; + } /* * Get the array values corresponding to each element name */ TclNewObj(tmpResPtr); - result = Tcl_ListObjGetElements(interp, nameLstPtr, - &count, &namePtrPtr); + 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); + valuePtr = Tcl_ObjGetVar2(interp, objv[2], namePtr, TCL_LEAVE_ERR_MSG); if (valuePtr == NULL) { /* * Some trace played a trick on us; we need to diagnose to @@ -2791,7 +2920,7 @@ Tcl_ArrayObjCmd( * the modification modify the complete array? */ - if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { + if (TclIsVarArray(varPtr)) { /* * The array itself looks OK, the variable was undefined: * forget it. @@ -2808,13 +2937,17 @@ Tcl_ArrayObjCmd( goto errorInArrayGet; } } - varPtr->refCount--; + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)--; + } Tcl_SetObjResult(interp, tmpResPtr); TclDecrRefCount(nameLstPtr); break; errorInArrayGet: - varPtr->refCount--; + if (TclIsVarInHash(varPtr)) { + VarHashRefCount(varPtr)--; + } TclDecrRefCount(nameLstPtr); TclDecrRefCount(tmpResPtr); /* free unneeded temp result */ return result; @@ -2852,11 +2985,10 @@ Tcl_ArrayObjCmd( TclNewObj(resultPtr); if (((enum options) mode)==OPT_GLOB && pattern!=NULL && TclMatchIsTrivial(pattern)) { - hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, pattern); - if ((hPtr != NULL) && - !TclIsVarUndefined((Var *) Tcl_GetHashValue(hPtr))) { + varPtr2 = VarHashFindVar(varPtr->value.tablePtr, objv[3]); + if ((varPtr2 != NULL) && !TclIsVarUndefined(varPtr2)) { result = Tcl_ListObjAppendElement(interp, resultPtr, - Tcl_NewStringObj(pattern, -1)); + VarHashGetKey(varPtr2)); if (result != TCL_OK) { TclDecrRefCount(resultPtr); return result; @@ -2865,13 +2997,13 @@ Tcl_ArrayObjCmd( Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } - for (hPtr=Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) { - varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search); + varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { if (TclIsVarUndefined(varPtr2)) { continue; } - name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); + namePtr = VarHashGetKey(varPtr2); + name = TclGetString(namePtr); if (objc > 3) { switch ((enum options) mode) { case OPT_EXACT: @@ -2893,10 +3025,8 @@ Tcl_ArrayObjCmd( } } - namePtr = Tcl_NewStringObj(name, -1); result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr); if (result != TCL_OK) { - TclDecrRefCount(resultPtr); TclDecrRefCount(namePtr); /* free unneeded name obj */ return result; } @@ -2914,7 +3044,6 @@ Tcl_ArrayObjCmd( Tcl_HashSearch search; Var *varPtr2; char *pattern = NULL; - char *name; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?"); @@ -2934,22 +3063,22 @@ Tcl_ArrayObjCmd( } else { pattern = TclGetString(objv[3]); if (TclMatchIsTrivial(pattern)) { - hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, pattern); - if (hPtr != NULL && - !TclIsVarUndefined((Var *)Tcl_GetHashValue(hPtr))){ - return TclObjUnsetVar2(interp, varNamePtr, pattern, 0); + varPtr2 = VarHashFindVar(varPtr->value.tablePtr, objv[3]); + if (varPtr2 != NULL && !TclIsVarUndefined(varPtr2)) { + return TclObjUnsetVar2(interp, varNamePtr, objv[3], 0); } return TCL_OK; } - for (hPtr=Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) { - varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search); + varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { + Tcl_Obj *namePtr; + if (TclIsVarUndefined(varPtr2)) { continue; } - name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr); - if (Tcl_StringMatch(name, pattern) && - TclObjUnsetVar2(interp, varNamePtr, name, + namePtr = VarHashGetKey(varPtr2); + if (Tcl_StringMatch(TclGetString(namePtr), pattern) && + TclObjUnsetVar2(interp, varNamePtr, namePtr, 0) != TCL_OK) { return TCL_ERROR; } @@ -2975,9 +3104,8 @@ Tcl_ArrayObjCmd( */ if (!notArray) { - for (hPtr=Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search)) { - varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search); + varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { if (TclIsVarUndefined(varPtr2)) { continue; } @@ -2995,7 +3123,7 @@ Tcl_ArrayObjCmd( goto error; } - stats = Tcl_HashStats(varPtr->value.tablePtr); + stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr); if (stats != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1)); ckfree((void *)stats); @@ -3009,7 +3137,7 @@ Tcl_ArrayObjCmd( return TCL_OK; error: - Tcl_AppendResult(interp, "\"", varName, "\" isn't an array", NULL); + Tcl_AppendResult(interp, "\"", TclGetString(varNamePtr), "\" isn't an array", NULL); return TCL_ERROR; } @@ -3039,26 +3167,19 @@ TclArraySet( * NULL, create an empty array. */ { Var *varPtr, *arrayPtr; - int result, i, nameLen; - char *varName, *p; - - varName = Tcl_GetStringFromObj(arrayNameObj, &nameLen); - p = varName + nameLen - 1; - if (*p == ')') { - while (--p >= varName) { - if (*p == '(') { - TclVarErrMsg(interp, varName, NULL, "set", needArray); - return TCL_ERROR; - } - } - } + int result, i; - varPtr = TclObjLookupVar(interp, arrayNameObj, NULL, + varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1, - /*createPart2*/ 0, &arrayPtr); + /*createPart2*/ 1, &arrayPtr); if (varPtr == NULL) { return TCL_ERROR; } + if (arrayPtr) { + CleanupVar(varPtr, arrayPtr); + TclObjVarErrMsg(interp, arrayNameObj, NULL, "set", needArray, -1); + return TCL_ERROR; + } if (arrayElemObj == NULL) { goto ensureArray; @@ -3095,16 +3216,15 @@ TclArraySet( Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done)) { /* * At this point, it would be nice if the key was directly usable - * by the array. This isn't the case though. + * by the array. This isn't the case though. /// */ - char *part2 = TclGetString(keyPtr); - Var *elemVarPtr = TclLookupArrayElement(interp, varName, - part2, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr); + Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj, + keyPtr, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); if ((elemVarPtr == NULL) || - (TclPtrSetVar(interp, elemVarPtr, varPtr, varName, - part2, valuePtr, TCL_LEAVE_ERR_MSG) == NULL)) { + (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj, + keyPtr, valuePtr, TCL_LEAVE_ERR_MSG, -1) == NULL)) { Tcl_DictObjDone(&search); return TCL_ERROR; } @@ -3140,13 +3260,12 @@ TclArraySet( copyListObj = TclListObjCopy(NULL, arrayElemObj); for (i=0 ; i<elemLen ; i+=2) { - char *part2 = TclGetString(elemPtrs[i]); - Var *elemVarPtr = TclLookupArrayElement(interp, varName, - part2, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr); + Var *elemVarPtr = TclLookupArrayElement(interp, arrayNameObj, + elemPtrs[i], TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr, -1); if ((elemVarPtr == NULL) || - (TclPtrSetVar(interp, elemVarPtr, varPtr, varName, part2, - elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL)) { + (TclPtrSetVar(interp, elemVarPtr, varPtr, arrayNameObj, elemPtrs[i], + elemPtrs[i+1], TCL_LEAVE_ERR_MSG, -1) == NULL)) { result = TCL_ERROR; break; } @@ -3162,7 +3281,7 @@ TclArraySet( ensureArray: if (varPtr != NULL) { - if (!TclIsVarUndefined(varPtr) && TclIsVarArray(varPtr)) { + if (TclIsVarArray(varPtr)) { /* * Already an array, done. */ @@ -3174,15 +3293,14 @@ TclArraySet( * Either an array element, or a scalar: lose! */ - TclVarErrMsg(interp, varName, NULL, "array set", needArray); + TclObjVarErrMsg(interp, arrayNameObj, NULL, "array set", needArray, -1); return TCL_ERROR; } } TclSetVarArray(varPtr); - TclClearVarUndefined(varPtr); - varPtr->value.tablePtr = (Tcl_HashTable *) - ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS); + varPtr->value.tablePtr = (TclVarHashTable *) + ckalloc(sizeof(TclVarHashTable)); + TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr)); return TCL_OK; } @@ -3216,7 +3334,7 @@ ObjMakeUpvar( 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. */ - const char *myName, /* Name of variable which will refer to + Tcl_Obj *myNamePtr, /* Name of variable which will refer to * otherP1/otherP2. Must be a scalar. */ int myFlags, /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: * indicates scope of myName. */ @@ -3259,19 +3377,21 @@ ObjMakeUpvar( */ if (index < 0) { - if (((arrayPtr ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL) + if (((arrayPtr + ? (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr)) + : (TclIsVarInHash(otherPtr) && TclGetVarNsPtr(otherPtr))) == 0) && ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) || (varFramePtr == NULL) || !HasLocalVars(varFramePtr) - || (strstr(myName, "::") != NULL))) { + || (strstr(TclGetString(myNamePtr), "::") != NULL))) { Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", - myName, "\": upvar won't create namespace variable that " + TclGetString(myNamePtr), "\": upvar won't create namespace variable that " "refers to procedure variable", NULL); return TCL_ERROR; } } - return TclPtrMakeUpvar(interp, otherPtr, myName, myFlags, index); + return TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index); } /* @@ -3306,18 +3426,48 @@ TclPtrMakeUpvar( int index) /* If the variable to be linked is an indexed * scalar, this is its index. Otherwise, -1 */ { + Tcl_Obj *myNamePtr; + int result; + + if (myName) { + myNamePtr = Tcl_NewStringObj(myName, -1); + Tcl_IncrRefCount(myNamePtr); + } else { + myNamePtr = NULL; + } + result = TclPtrObjMakeUpvar(interp, otherPtr, myNamePtr, myFlags, index); + if (myNamePtr) { + Tcl_DecrRefCount(myNamePtr); + } + return result; +} + +int +TclPtrObjMakeUpvar( + Tcl_Interp *interp, /* Interpreter containing variables. Used for + * error messages, too. */ + Var *otherPtr, /* Pointer to the variable being linked-to */ + Tcl_Obj *myNamePtr, /* Name of variable which will refer to + * otherP1/otherP2. Must be a scalar. */ + 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 */ +{ Interp *iPtr = (Interp *) interp; CallFrame *varFramePtr = iPtr->varFramePtr; Var *varPtr; const char *errMsg; - const char *p; + const char *p; + const char *myName; if (index >= 0) { if (!HasLocalVars(varFramePtr)) { Tcl_Panic("ObjMakeUpvar called with an index outside from a proc"); } - varPtr = &(varFramePtr->compiledLocals[index]); - myName = varPtr->name; + varPtr = (Var *) &(varFramePtr->compiledLocals[index]); + myNamePtr = localName(iPtr->varFramePtr, index); + myName = myNamePtr? TclGetString(myNamePtr) : NULL; } else { /* * Do not permit the new variable to look like an array reference, as @@ -3326,6 +3476,7 @@ TclPtrMakeUpvar( * (and must remain consistent) with the code in TclObjLookupVar(). */ + myName = TclGetString(myNamePtr); p = strstr(myName, "("); if (p != NULL) { p += strlen(p)-1; @@ -3350,10 +3501,10 @@ TclPtrMakeUpvar( * - Bug #631741 - do not use special namespace or interp resolvers. */ - varPtr = TclLookupSimpleVar(interp, myName, (myFlags|LOOKUP_FOR_UPVAR), + varPtr = TclLookupSimpleVar(interp, myNamePtr, (myFlags|LOOKUP_FOR_UPVAR), /* create */ 1, &errMsg, &index); if (varPtr == NULL) { - TclVarErrMsg(interp, myName, NULL, "create", errMsg); + TclObjVarErrMsg(interp, myNamePtr, NULL, "create", errMsg, -1); return TCL_ERROR; } } @@ -3364,7 +3515,7 @@ TclPtrMakeUpvar( return TCL_ERROR; } - if (varPtr->tracePtr != NULL) { + if (TclIsVarTraced(varPtr)) { Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, "\" has traces: can't use for upvar", NULL); return TCL_ERROR; @@ -3381,9 +3532,11 @@ TclPtrMakeUpvar( if (linkPtr == otherPtr) { return TCL_OK; } - linkPtr->refCount--; - if (TclIsVarUndefined(linkPtr)) { - TclCleanupVar(linkPtr, NULL); + if (TclIsVarInHash(linkPtr)) { + VarHashRefCount(linkPtr)--; + if (TclIsVarUndefined(linkPtr)) { + CleanupVar(linkPtr, NULL); + } } } else { Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName, @@ -3392,9 +3545,10 @@ TclPtrMakeUpvar( } } TclSetVarLink(varPtr); - TclClearVarUndefined(varPtr); varPtr->value.linkPtr = otherPtr; - otherPtr->refCount++; + if (TclIsVarInHash(otherPtr)) { + VarHashRefCount(otherPtr)++; + } return TCL_OK; } @@ -3469,7 +3623,7 @@ Tcl_UpVar2( { int result; CallFrame *framePtr; - Tcl_Obj *part1Ptr; + Tcl_Obj *part1Ptr, *localNamePtr; if (TclGetFrame(interp, frameName, &framePtr) == -1) { return TCL_ERROR; @@ -3477,10 +3631,13 @@ Tcl_UpVar2( part1Ptr = Tcl_NewStringObj(part1, -1); Tcl_IncrRefCount(part1Ptr); - result = ObjMakeUpvar(interp, framePtr, part1Ptr, part2, 0, - localName, flags, -1); - TclDecrRefCount(part1Ptr); + localNamePtr = Tcl_NewStringObj(localName, -1); + Tcl_IncrRefCount(localNamePtr); + result = ObjMakeUpvar(interp, framePtr, part1Ptr, part2, 0, + localNamePtr, flags, -1); + Tcl_DecrRefCount(part1Ptr); + Tcl_DecrRefCount(localNamePtr); return result; } @@ -3513,26 +3670,35 @@ Tcl_GetVariableFullName( { Interp *iPtr = (Interp *) interp; register Var *varPtr = (Var *) variable; - char *name; + Tcl_Obj *namePtr; + Namespace *nsPtr; /* * Add the full name of the containing namespace (if any), followed by the * "::" separator, then the variable name. */ - if (varPtr != NULL) { + if (varPtr) { if (!TclIsVarArrayElement(varPtr)) { - if (varPtr->nsPtr != NULL) { - Tcl_AppendToObj(objPtr, varPtr->nsPtr->fullName, -1); - if (varPtr->nsPtr != iPtr->globalNsPtr) { + nsPtr = TclGetVarNsPtr(varPtr); + if (nsPtr) { + Tcl_AppendToObj(objPtr, nsPtr->fullName, -1); + if (nsPtr != iPtr->globalNsPtr) { Tcl_AppendToObj(objPtr, "::", 2); } } - if (varPtr->name != NULL) { - Tcl_AppendToObj(objPtr, varPtr->name, -1); - } else if (varPtr->hPtr != NULL) { - name = Tcl_GetHashKey(varPtr->hPtr->tablePtr, varPtr->hPtr); - Tcl_AppendToObj(objPtr, name, -1); + if (TclIsVarInHash(varPtr)) { + if (!TclIsVarDeadHash(varPtr)) { + namePtr = VarHashGetKey(varPtr); + Tcl_AppendObjToObj(objPtr, namePtr); + } + } else if (iPtr->varFramePtr->procPtr) { + int index = varPtr - iPtr->varFramePtr->compiledLocals; + + if (index < iPtr->varFramePtr->numCompiledLocals) { + namePtr = localName(iPtr->varFramePtr, index); + Tcl_AppendObjToObj(objPtr, namePtr); + } } } } @@ -3563,7 +3729,7 @@ Tcl_GlobalObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Interp *iPtr = (Interp *) interp; - register Tcl_Obj *objPtr; + register Tcl_Obj *objPtr, *tailPtr; char *varName; register char *tail; int result, i; @@ -3605,12 +3771,24 @@ Tcl_GlobalObjCmd( tail++; } + if (tail == varName) { + tailPtr = objPtr; + } else { + tailPtr = Tcl_NewStringObj(tail, -1); + Tcl_IncrRefCount(tailPtr); + } + /* * Link to the variable "varName" in the global :: namespace. */ result = ObjMakeUpvar(interp, NULL, objPtr, NULL, - TCL_GLOBAL_ONLY, /*myName*/ tail, /*myFlags*/ 0, -1); + TCL_GLOBAL_ONLY, /*myName*/ tailPtr, /*myFlags*/ 0, -1); + + if (tail != varName) { + Tcl_DecrRefCount(tailPtr); + } + if (result != TCL_OK) { return result; } @@ -3664,7 +3842,7 @@ Tcl_VariableObjCmd( Var *varPtr, *arrayPtr; Tcl_Obj *varValuePtr; int i, result; - Tcl_Obj *varNamePtr; + Tcl_Obj *varNamePtr, *tailPtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?name value...? name ?value?"); @@ -3679,7 +3857,7 @@ Tcl_VariableObjCmd( varNamePtr = objv[i]; varName = TclGetString(varNamePtr); - varPtr = TclObjLookupVar(interp, varNamePtr, NULL, + varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "define", /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr); @@ -3689,7 +3867,7 @@ Tcl_VariableObjCmd( * non-NULL, it is, so throw up an error and return. */ - TclVarErrMsg(interp, varName, NULL, "define", isArrayElement); + TclObjVarErrMsg(interp, varNamePtr, NULL, "define", isArrayElement, -1); return TCL_ERROR; } @@ -3703,10 +3881,7 @@ Tcl_VariableObjCmd( * destroyed or until the variable is unset. */ - if (!TclIsVarNamespaceVar(varPtr)) { - TclSetVarNamespaceVar(varPtr); - varPtr->refCount++; - } + TclSetVarNamespaceVar(varPtr); /* * If a value was specified, set the variable to that value. @@ -3716,8 +3891,8 @@ Tcl_VariableObjCmd( */ if (i+1 < objc) { /* a value was specified */ - varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, varName, NULL, - objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG)); + varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, varNamePtr, NULL, + objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), -1); if (varValuePtr == NULL) { return TCL_ERROR; } @@ -3750,9 +3925,21 @@ Tcl_VariableObjCmd( * current namespace. */ + if (tail == varName) { + tailPtr = varNamePtr; + } else { + tailPtr = Tcl_NewStringObj(tail, -1); + Tcl_IncrRefCount(tailPtr); + } + result = ObjMakeUpvar(interp, NULL, varNamePtr, /*otherP2*/ NULL, /*otherFlags*/ TCL_NAMESPACE_ONLY, - /*myName*/ tail, /*myFlags*/ 0, -1); + /*myName*/ tailPtr, /*myFlags*/ 0, -1); + + if (tail != varName) { + Tcl_DecrRefCount(tailPtr); + } + if (result != TCL_OK) { return result; } @@ -3787,7 +3974,6 @@ Tcl_UpvarObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { CallFrame *framePtr; - char *localName; int result; if (objc < 3) { @@ -3819,9 +4005,8 @@ Tcl_UpvarObjCmd( */ for (; objc>0 ; objc-=2, objv+=2) { - localName = TclGetString(objv[1]); result = ObjMakeUpvar(interp, framePtr, /* othervarName */ objv[0], - NULL, 0, /* myVarName */ localName, /*flags*/ 0, -1); + NULL, 0, /* myVarName */ objv[1], /*flags*/ 0, -1); if (result != TCL_OK) { return TCL_ERROR; } @@ -3832,44 +4017,6 @@ Tcl_UpvarObjCmd( /* *---------------------------------------------------------------------- * - * NewVar -- - * - * Create a new heap-allocated variable that will eventually be entered - * into a hashtable. - * - * Results: - * The return value is a pointer to the new variable structure. It is - * marked as a scalar variable (and not a link or array variable). Its - * value initially is NULL. The variable is not part of any hash table - * yet. Since it will be in a hashtable and not in a call frame, its name - * field is set NULL. It is initially marked as undefined. - * - * Side effects: - * Storage gets allocated. - * - *---------------------------------------------------------------------- - */ - -static Var * -NewVar(void) -{ - register Var *varPtr; - - varPtr = (Var *) ckalloc(sizeof(Var)); - varPtr->value.objPtr = NULL; - varPtr->name = NULL; - varPtr->nsPtr = NULL; - varPtr->hPtr = NULL; - varPtr->refCount = 0; - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - varPtr->flags = (VAR_SCALAR | VAR_UNDEFINED | VAR_IN_HASHTABLE); - return varPtr; -} - -/* - *---------------------------------------------------------------------- - * * SetArraySearchObj -- * * This function converts the given tcl object into one that has the @@ -3959,17 +4106,19 @@ static ArraySearch * ParseSearchId( Tcl_Interp *interp, /* Interpreter containing variable. */ const Var *varPtr, /* Array variable search is for. */ - const char *varName, /* Name of array variable that search is + Tcl_Obj *varNamePtr, /* Name of array variable that search is * supposed to be for. */ 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. */ { + Interp *iPtr = (Interp *) interp; register char *string; register size_t offset; int id; ArraySearch *searchPtr; + char *varName = TclGetString(varNamePtr); /* * Parse the id. @@ -4012,10 +4161,15 @@ ParseSearchId( * this list every time. */ - for (searchPtr = varPtr->searchPtr; searchPtr != NULL; - searchPtr = searchPtr->nextPtr) { - if (searchPtr->id == id) { - return searchPtr; + if (varPtr->flags & VAR_SEARCH_ACTIVE) { + Tcl_HashEntry *hPtr = + Tcl_FindHashEntry(&iPtr->varSearches,(char *) varPtr); + + for (searchPtr = (ArraySearch *) Tcl_GetHashValue(hPtr); + searchPtr != NULL; searchPtr = searchPtr->nextPtr) { + if (searchPtr->id == id) { + return searchPtr; + } } } Tcl_AppendResult(interp, "couldn't find search \"", string, "\"", NULL); @@ -4042,16 +4196,23 @@ ParseSearchId( static void DeleteSearches( + Interp *iPtr, register Var *arrayVarPtr) /* Variable whose searches are to be * deleted. */ { - ArraySearch *searchPtr; - - while (arrayVarPtr->searchPtr != NULL) { - searchPtr = arrayVarPtr->searchPtr; - arrayVarPtr->searchPtr = searchPtr->nextPtr; - ckfree((char *) searchPtr); - } + ArraySearch *searchPtr, *nextPtr; + Tcl_HashEntry *sPtr; + + if (arrayVarPtr->flags & VAR_SEARCH_ACTIVE) { + sPtr = Tcl_FindHashEntry(&iPtr->varSearches, (char *) arrayVarPtr); + for (searchPtr = (ArraySearch *) Tcl_GetHashValue(sPtr); + searchPtr != NULL; searchPtr = nextPtr) { + nextPtr = searchPtr->nextPtr; + ckfree((char *) searchPtr); + } + arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE; + Tcl_DeleteHashEntry(sPtr); + } } /* @@ -4076,12 +4237,12 @@ void TclDeleteNamespaceVars( Namespace *nsPtr) { - Tcl_HashTable *tablePtr = &nsPtr->varTable; + TclVarHashTable *tablePtr = &nsPtr->varTable; Tcl_Interp *interp = nsPtr->interp; Interp *iPtr = (Interp *)interp; Tcl_HashSearch search; - Tcl_HashEntry *hPtr; int flags = 0; + Var *varPtr; /* * Determine what flags to pass to the trace callback functions. @@ -4093,30 +4254,33 @@ TclDeleteNamespaceVars( flags = TCL_NAMESPACE_ONLY; } - for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; - hPtr = Tcl_FirstHashEntry(tablePtr, &search)) { - register Var *varPtr = (Var *) Tcl_GetHashValue(hPtr); - varPtr->refCount++; /* Make sure we get to remove from hash */ - UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ NULL, NULL, flags, 1); - varPtr->refCount--; + for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL; + varPtr = VarHashFirstVar(tablePtr, &search)) { + VarHashRefCount(varPtr)++; /* Make sure we get to remove from hash */ + UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ VarHashGetKey(varPtr), NULL, flags); /* * Remove the variable from the table and force it undefined in case * an unset trace brought it back from the dead. */ - Tcl_DeleteHashEntry(hPtr); - varPtr->hPtr = NULL; - TclSetVarUndefined(varPtr); - TclSetVarScalar(varPtr); - while (varPtr->tracePtr != NULL) { - VarTrace *tracePtr = varPtr->tracePtr; - varPtr->tracePtr = tracePtr->nextPtr; - Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); + if (TclIsVarTraced(varPtr)) { + Tcl_HashEntry *tPtr = Tcl_FindHashEntry(&iPtr->varTraces, + (char *) varPtr); + VarTrace *tracePtr = (VarTrace *) Tcl_GetHashValue(tPtr); + while (tracePtr) { + VarTrace *prevPtr = tracePtr; + + tracePtr = tracePtr->nextPtr; + Tcl_EventuallyFree((ClientData) prevPtr, TCL_DYNAMIC); + } + Tcl_DeleteHashEntry(tPtr); + varPtr->flags &= ~VAR_ALL_TRACES; } - TclCleanupVar(varPtr, NULL); + VarHashRefCount(varPtr)--; + VarHashDeleteEntry(varPtr); } - Tcl_DeleteHashTable(tablePtr); + VarHashDeleteTable(tablePtr); } /* @@ -4142,12 +4306,11 @@ TclDeleteNamespaceVars( void TclDeleteVars( Interp *iPtr, /* Interpreter to which variables belong. */ - Tcl_HashTable *tablePtr) /* Hash table containing variables to + TclVarHashTable *tablePtr) /* Hash table containing variables to * delete. */ { Tcl_Interp *interp = (Tcl_Interp *) iPtr; Tcl_HashSearch search; - Tcl_HashEntry *hPtr; register Var *varPtr; int flags; Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); @@ -4163,24 +4326,17 @@ TclDeleteVars( flags |= TCL_NAMESPACE_ONLY; } - for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; - hPtr = Tcl_NextHashEntry(&search)) { - varPtr = (Var *) Tcl_GetHashValue(hPtr); - - UnsetVarStruct(varPtr, NULL, iPtr, NULL, NULL, flags, 0); - varPtr->hPtr = NULL; - + for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL; + varPtr = VarHashNextVar(&search)) { /* - * Recycle the variable's memory space if there aren't any upvar's - * pointing to it. If there are upvars to this variable, then the - * variable will get freed when the last upvar goes away. + * Lie about the validity of the hashtable entry. In this way the + * variables will be deleted by VarHashDeleteTable. */ - - if (varPtr->refCount == 0) { - ckfree((char *) varPtr); /* this Var must be VAR_IN_HASHTABLE */ - } + + VarHashInvalidateEntry(varPtr); + UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr), NULL, flags); } - Tcl_DeleteHashTable(tablePtr); + VarHashDeleteTable(tablePtr); } /* @@ -4213,77 +4369,13 @@ TclDeleteCompiledLocalVars( { register Var *varPtr; int numLocals, i; - + Tcl_Obj **namePtrPtr; + numLocals = framePtr->numCompiledLocals; varPtr = framePtr->compiledLocals; - for (i=0 ; i<numLocals ; i++) { -#if 1 - UnsetVarStruct(varPtr, NULL, iPtr, varPtr->name, NULL, TCL_TRACE_UNSETS, 0); - varPtr++; -#else - if (!TclIsVarUntraced(varPtr)) { - ActiveVarTrace *activePtr; - - varPtr->flags &= ~VAR_TRACE_ACTIVE; - TclCallVarTraces(iPtr, NULL, varPtr, varPtr->name, NULL, - TCL_TRACE_UNSETS, /* leaveErrMsg */ 0); - while (varPtr->tracePtr != NULL) { - VarTrace *tracePtr = varPtr->tracePtr; - varPtr->tracePtr = tracePtr->nextPtr; - Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); - } - for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; - activePtr = activePtr->nextPtr) { - if (activePtr->varPtr == varPtr) { - activePtr->nextTracePtr = NULL; - } - } - } - - if (TclIsVarScalar(varPtr) - && (varPtr->value.objPtr != NULL)) { - /* - * Decrement the ref count of the var's value - */ - - Tcl_Obj *objPtr = varPtr->value.objPtr; - TclDecrRefCount(objPtr); - varPtr->value.objPtr = NULL; - } else if (TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { - /* - * If the variable is an array, delete all of its elements. This must - * be done after calling the traces on the array, above (that's the - * way traces are defined). If the array is traced, its name is - * already in part1. If not, and the name is required for some - * element, it will be computed at DeleteArray. - */ - - DeleteArray(iPtr, varPtr->name, varPtr, TCL_TRACE_UNSETS); - } else if (TclIsVarLink(varPtr)) { - /* - * For global/upvar variables referenced in procedures, decrement the - * reference count on the variable referred to, and free the - * referenced variable if it's no longer needed. - */ - Var *linkPtr = varPtr->value.linkPtr; - linkPtr->refCount--; - if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr) - && (linkPtr->tracePtr == NULL) - && (linkPtr->flags & VAR_IN_HASHTABLE)) { - if (linkPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(linkPtr->hPtr); - } - ckfree((char *) linkPtr); - } - } - - TclSetVarUndefined(varPtr); - TclSetVarScalar(varPtr); - varPtr->tracePtr = NULL; - varPtr->searchPtr = NULL; - - varPtr++; -#endif + namePtrPtr = &localName(framePtr, 0); + for (i=0 ; i<numLocals ; i++, namePtrPtr++, varPtr++) { + UnsetVarStruct(varPtr, NULL, iPtr, *namePtrPtr, NULL, TCL_TRACE_UNSETS); } } @@ -4311,7 +4403,7 @@ TclDeleteCompiledLocalVars( static void DeleteArray( Interp *iPtr, /* Interpreter containing array. */ - const char *arrayName, /* Name of array (used for trace callbacks), + Tcl_Obj *arrayNamePtr, /* Name of array (used for trace callbacks), * or NULL if it is to be computed on demand */ Var *varPtr, /* Pointer to variable structure. */ int flags) /* Flags to pass to TclCallVarTraces: @@ -4319,44 +4411,51 @@ DeleteArray( * TCL_NAMESPACE_ONLY or TCL_GLOBAL_ONLY. */ { Tcl_HashSearch search; - register Tcl_HashEntry *hPtr; + Tcl_HashEntry *tPtr; register Var *elPtr; ActiveVarTrace *activePtr; - Tcl_Obj *objPtr, *arrayNamePtr = NULL; + Tcl_Obj *objPtr; + VarTrace *tracePtr; - DeleteSearches(varPtr); - for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); - hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - elPtr = (Var *) Tcl_GetHashValue(hPtr); + if (varPtr->flags & VAR_SEARCH_ACTIVE) { + DeleteSearches(iPtr, varPtr); + } + for (elPtr = VarHashFirstVar(varPtr->value.tablePtr, &search); + elPtr != NULL; elPtr = VarHashNextVar(&search)) { if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) { objPtr = elPtr->value.objPtr; TclDecrRefCount(objPtr); elPtr->value.objPtr = NULL; } - elPtr->hPtr = NULL; - if (elPtr->tracePtr != NULL) { + + /* + * Lie about the validity of the hashtable entry. In this way the + * variables will be deleted by VarHashDeleteTable. + */ + + VarHashInvalidateEntry(elPtr); + if (TclIsVarTraced(elPtr)) { /* * Compute the array name if it was not supplied */ - if (arrayName == NULL) { - Tcl_Interp *interp = varPtr->nsPtr->interp; - TclNewObj(arrayNamePtr); - Tcl_IncrRefCount(arrayNamePtr); - Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, arrayNamePtr); - arrayName = TclGetString(arrayNamePtr); + if (elPtr->flags & VAR_TRACED_UNSET) { + Tcl_Obj *elNamePtr = VarHashGetKey(elPtr); + + elPtr->flags &= ~VAR_TRACE_ACTIVE; + TclObjCallVarTraces(iPtr, NULL, elPtr, arrayNamePtr, + elNamePtr, flags,/* leaveErrMsg */ 0, -1); } - - elPtr->flags &= ~VAR_TRACE_ACTIVE; - TclCallVarTraces(iPtr, NULL, elPtr, arrayName, - Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags, - /* leaveErrMsg */ 0); - while (elPtr->tracePtr != NULL) { - VarTrace *tracePtr = elPtr->tracePtr; - - elPtr->tracePtr = tracePtr->nextPtr; - Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC); + tPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) elPtr); + tracePtr = (VarTrace *) Tcl_GetHashValue(tPtr); + while (tracePtr) { + VarTrace *prevPtr = tracePtr; + + tracePtr = tracePtr->nextPtr; + Tcl_EventuallyFree((ClientData) prevPtr, TCL_DYNAMIC); } + Tcl_DeleteHashEntry(tPtr); + elPtr->flags &= ~VAR_ALL_TRACES; for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL; activePtr = activePtr->nextPtr) { if (activePtr->varPtr == elPtr) { @@ -4365,7 +4464,6 @@ DeleteArray( } } TclSetVarUndefined(elPtr); - TclSetVarScalar(elPtr); /* * Even though array elements are not supposed to be namespace @@ -4374,73 +4472,16 @@ DeleteArray( * the corresponding Var struct, and is otherwise harmless. */ - if (TclIsVarNamespaceVar(elPtr)) { - TclClearVarNamespaceVar(elPtr); - elPtr->refCount--; - } - if (elPtr->refCount == 0) { - ckfree((char *) elPtr); /* element Vars are VAR_IN_HASHTABLE */ - } - } - if (arrayNamePtr) { - Tcl_DecrRefCount(arrayNamePtr); + TclClearVarNamespaceVar(elPtr); } - Tcl_DeleteHashTable(varPtr->value.tablePtr); + VarHashDeleteTable(varPtr->value.tablePtr); ckfree((char *) varPtr->value.tablePtr); } /* *---------------------------------------------------------------------- * - * TclCleanupVar -- - * - * This function is called when it looks like it may be OK to free up a - * variable's storage. If the variable is in a hashtable, its Var - * structure and hash table entry will be freed along with those of its - * containing array, if any. This function is called, for example, when - * a trace on a variable deletes a variable. - * - * Results: - * None. - * - * Side effects: - * If the variable (or its containing array) really is dead and in a - * hashtable, then its Var structure, and possibly its hash table entry, - * is freed up. - * - *---------------------------------------------------------------------- - */ - -void -TclCleanupVar( - Var *varPtr, /* Pointer to variable that may be a candidate - * for being expunged. */ - Var *arrayPtr) /* Array that contains the variable, or NULL - * if this variable isn't an array element. */ -{ - if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0) - && (varPtr->tracePtr == NULL) - && (varPtr->flags & VAR_IN_HASHTABLE)) { - if (varPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(varPtr->hPtr); - } - ckfree((char *) varPtr); - } - if (arrayPtr != NULL) { - if (TclIsVarUndefined(arrayPtr) && (arrayPtr->refCount == 0) - && (arrayPtr->tracePtr == NULL) - && (arrayPtr->flags & VAR_IN_HASHTABLE)) { - if (arrayPtr->hPtr != NULL) { - Tcl_DeleteHashEntry(arrayPtr->hPtr); - } - ckfree((char *) arrayPtr); - } - } -} -/* - *---------------------------------------------------------------------- - * - * TclVarErrMsg -- + * TclTclObjVarErrMsg -- * * Generate a reasonable error message describing why a variable * operation failed. @@ -4459,16 +4500,49 @@ TclCleanupVar( void TclVarErrMsg( Tcl_Interp *interp, /* Interpreter in which to record message. */ - const char *part1, + 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". */ const char *reason) /* String describing why operation failed. */ { + Tcl_Obj *part1Ptr = NULL, *part2Ptr = NULL; + + part1Ptr = Tcl_NewStringObj(part1, -1); + Tcl_IncrRefCount(part1Ptr); + if (part2) { + part2Ptr = Tcl_NewStringObj(part2, -1); + Tcl_IncrRefCount(part2Ptr); + } else { + part2 = NULL; + } + + TclObjVarErrMsg(interp, part1Ptr, part2Ptr, operation, reason, -1); + + Tcl_DecrRefCount(part1Ptr); + if (part2Ptr) { + Tcl_DecrRefCount(part2Ptr); + } +} + +void +TclObjVarErrMsg( + Tcl_Interp *interp, /* Interpreter in which to record message. */ + Tcl_Obj *part1Ptr, /* (may be NULL, if index >= 0) */ + Tcl_Obj *part2Ptr, /* Variable's two-part name. */ + const char *operation, /* String describing operation that failed, + * e.g. "read", "set", or "unset". */ + const char *reason, /* String describing why operation failed. */ + int index) +{ Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "can't ", operation, " \"", part1, NULL); - if (part2 != NULL) { - Tcl_AppendResult(interp, "(", part2, ")", NULL); + if (!part1Ptr) { + part1Ptr = localName(((Interp*)interp)->varFramePtr, index); + } + Tcl_AppendResult(interp, "can't ", operation, " \"", + TclGetString(part1Ptr), NULL); + if (part2Ptr) { + Tcl_AppendResult(interp, "(", TclGetString(part2Ptr), ")", NULL); } Tcl_AppendResult(interp, "\": ", reason, NULL); } @@ -4534,9 +4608,11 @@ FreeNsVarName( { register Var *varPtr = objPtr->internalRep.twoPtrValue.ptr2; - varPtr->refCount--; - if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0)) { - TclCleanupVar(varPtr, NULL); + if (TclIsVarInHash(varPtr)) { + varPtr->refCount--; + if (TclIsVarUndefined(varPtr) && (varPtr->refCount == 0)) { + CleanupVar(varPtr, NULL); + } } } @@ -4550,7 +4626,9 @@ DupNsVarName( dupPtr->internalRep.twoPtrValue.ptr1 = nsPtr; dupPtr->internalRep.twoPtrValue.ptr2 = varPtr; - varPtr->refCount++; + if (TclIsVarInHash(varPtr)) { + varPtr->refCount++; + } dupPtr->typePtr = &tclNsVarNameType; } #endif @@ -4636,6 +4714,701 @@ UpdateParsedVarName( } /* + *---------------------------------------------------------------------- + * + * Tcl_FindNamespaceVar -- MOVED OVER from tclNamesp.c + * + * Searches for a namespace variable, a variable not local to a + * procedure. The variable can be either a scalar or an array, but may + * not be an element of an array. + * + * Results: + * Returns a token for the variable if it is found. Otherwise, if it + * can't be found or there is an error, returns NULL and leaves an error + * message in the interpreter's result object if "flags" contains + * TCL_LEAVE_ERR_MSG. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Var +Tcl_FindNamespaceVar( + Tcl_Interp *interp, /* The interpreter in which to find the + * variable. */ + const char *name, /* Variable's name. If it starts with "::", + * will be looked up in global namespace. + * Else, looked up first in contextNsPtr + * (current namespace if contextNsPtr is + * NULL), then in global namespace. */ + Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag set. + * Otherwise, points to namespace in which to + * resolve name. If NULL, look up name in the + * current namespace. */ + int flags) /* An OR'd combination of flags: + * TCL_GLOBAL_ONLY (look up name only in + * global namespace), TCL_NAMESPACE_ONLY (look + * up only in contextNsPtr, or the current + * namespace if contextNsPtr is NULL), and + * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY + * and TCL_NAMESPACE_ONLY are given, + * TCL_GLOBAL_ONLY is ignored. */ +{ + Interp *iPtr = (Interp *) interp; + ResolverScheme *resPtr; + Namespace *nsPtr[2], *cxtNsPtr; + const char *simpleName; + Var *varPtr; + register int search; + int result; + Tcl_Var var; + Tcl_Obj *simpleNamePtr; + + /* + * If this namespace has a variable resolver, then give it first crack at + * the variable resolution. It may return a Tcl_Var value, it may signal + * to continue onward, or it may signal an error. + */ + + if ((flags & TCL_GLOBAL_ONLY) != 0) { + cxtNsPtr = (Namespace *) TclGetGlobalNamespace(interp); + } else if (contextNsPtr != NULL) { + cxtNsPtr = (Namespace *) contextNsPtr; + } else { + cxtNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + } + + if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { + resPtr = iPtr->resolverPtr; + + if (cxtNsPtr->varResProc) { + result = (*cxtNsPtr->varResProc)(interp, name, + (Tcl_Namespace *) cxtNsPtr, flags, &var); + } else { + result = TCL_CONTINUE; + } + + while (result == TCL_CONTINUE && resPtr) { + if (resPtr->varResProc) { + result = (*resPtr->varResProc)(interp, name, + (Tcl_Namespace *) cxtNsPtr, flags, &var); + } + resPtr = resPtr->nextPtr; + } + + if (result == TCL_OK) { + return var; + } else if (result != TCL_CONTINUE) { + return (Tcl_Var) NULL; + } + } + + /* + * Find the namespace(s) that contain the variable. + */ + + TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, + flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); + + /* + * Look for the variable in the variable table of its namespace. Be sure + * to check both possible search paths: from the specified namespace + * context and from the global namespace. + */ + + varPtr = NULL; + simpleNamePtr = Tcl_NewStringObj(simpleName, -1); + Tcl_IncrRefCount(simpleNamePtr); + for (search = 0; (search < 2) && (varPtr == NULL); search++) { + if ((nsPtr[search] != NULL) && (simpleName != NULL)) { + varPtr = VarHashFindVar(&nsPtr[search]->varTable, simpleNamePtr); + } + } + Tcl_DecrRefCount(simpleNamePtr); + if (varPtr != NULL) { + return (Tcl_Var) varPtr; + } else if (flags & TCL_LEAVE_ERR_MSG) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "unknown variable \"", name, "\"", NULL); + } + return (Tcl_Var) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * InfoVarsCmd -- (moved over from tclCmdIL.c) + * + * Called to implement the "info vars" command that returns the list of + * variables in the interpreter that match an optional pattern. The + * pattern, if any, consists of an optional sequence of namespace names + * separated by "::" qualifiers, which is followed by a glob-style + * pattern that restricts which variables are returned. Handles the + * following syntax: + * + * info vars ?pattern? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +int +TclInfoVarsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + char *varName, *pattern; + CONST char *simplePattern; + Tcl_HashSearch search; + Var *varPtr; + Namespace *nsPtr; + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Tcl_Obj *listPtr, *elemObjPtr; + int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ + Tcl_Obj *simplePatternPtr = NULL, *varNamePtr; + + /* + * Get the pattern and find the "effective namespace" in which to list + * variables. We only use this effective namespace if there's no active + * Tcl procedure frame. + */ + + if (objc == 1) { + simplePattern = NULL; + nsPtr = currNsPtr; + specificNsInPattern = 0; + } else if (objc == 2) { + /* + * From the pattern, get the effective namespace and the simple + * pattern (no namespace qualifiers or ::'s) at the end. If an error + * was found while parsing the pattern, return it. Otherwise, if the + * namespace wasn't found, just leave nsPtr NULL: we will return an + * empty list since no variables there can be found. + */ + + Namespace *dummy1NsPtr, *dummy2NsPtr; + + pattern = TclGetString(objv[1]); + TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, + /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, + &simplePattern); + + if (nsPtr != NULL) { /* We successfully found the pattern's ns. */ + specificNsInPattern = (strcmp(simplePattern, pattern) != 0); + if (simplePattern == pattern) { + simplePatternPtr = objv[1]; + } else { + simplePatternPtr = Tcl_NewStringObj(simplePattern, -1); + } + Tcl_IncrRefCount(simplePatternPtr); + } + } else { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); + return TCL_ERROR; + } + + /* + * If the namespace specified in the pattern wasn't found, just return. + */ + + if (nsPtr == NULL) { + return TCL_OK; + } + + listPtr = Tcl_NewListObj(0, NULL); + + if (!(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC) + || specificNsInPattern) { + /* + * There is no frame pointer, the frame pointer was pushed only to + * activate a namespace, or we are in a procedure call frame but a + * specific namespace was specified. Create a list containing only the + * variables in the effective namespace's variable table. + */ + + if (simplePattern && TclMatchIsTrivial(simplePattern)) { + /* + * If we can just do hash lookups, that simplifies things a lot. + */ + + varPtr = VarHashFindVar(&nsPtr->varTable, simplePatternPtr); + if (varPtr) { + if (!TclIsVarUndefined(varPtr) + || TclIsVarNamespaceVar(varPtr)) { + if (specificNsInPattern) { + elemObjPtr = Tcl_NewObj(); + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, + elemObjPtr); + } else { + elemObjPtr = VarHashGetKey(varPtr); + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } + } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + varPtr = VarHashFindVar(&globalNsPtr->varTable, simplePatternPtr); + if (varPtr) { + if (!TclIsVarUndefined(varPtr) + || TclIsVarNamespaceVar(varPtr)) { + Tcl_ListObjAppendElement(interp, listPtr, + VarHashGetKey(varPtr)); + } + } + } + } else { + /* + * Have to scan the tables of variables. + */ + + varPtr = VarHashFirstVar(&nsPtr->varTable, &search); + while (varPtr) { + if (!TclIsVarUndefined(varPtr) + || TclIsVarNamespaceVar(varPtr)) { + varNamePtr = VarHashGetKey(varPtr); + varName = TclGetString(varNamePtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(varName, simplePattern)) { + if (specificNsInPattern) { + elemObjPtr = Tcl_NewObj(); + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, + elemObjPtr); + } else { + elemObjPtr = varNamePtr; + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } + } + varPtr = VarHashNextVar(&search); + } + + /* + * If the effective namespace isn't the global :: namespace, and a + * specific namespace wasn't requested in the pattern (i.e., the + * pattern only specifies variable names), then add in all global + * :: variables that match the simple pattern. Of course, add in + * only those variables that aren't hidden by a variable in the + * effective namespace. + */ + + if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + varPtr = VarHashFirstVar(&globalNsPtr->varTable,&search); + while (varPtr) { + if (!TclIsVarUndefined(varPtr) + || TclIsVarNamespaceVar(varPtr)) { + varNamePtr = VarHashGetKey(varPtr); + varName = TclGetString(varNamePtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(varName, simplePattern)) { + if (VarHashFindVar(&nsPtr->varTable, varNamePtr) == NULL) { + Tcl_ListObjAppendElement(interp, listPtr, varNamePtr); + } + } + } + varPtr = VarHashNextVar(&search); + } + } + } + } else if (((Interp *)interp)->varFramePtr->procPtr != NULL) { + AppendLocals(interp, listPtr, simplePatternPtr, 1); + } + + if (simplePatternPtr) { + Tcl_DecrRefCount(simplePatternPtr); + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InfoGlobalsCmd -- (moved over from tclCmdIL.c) + * + * Called to implement the "info globals" command that returns the list + * of global variables matching an optional pattern. Handles the + * following syntax: + * + * info globals ?pattern? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +int +TclInfoGlobalsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ +{ + char *varName, *pattern; + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + Tcl_HashSearch search; + Var *varPtr; + Tcl_Obj *listPtr, *varNamePtr, *patternPtr; + + if (objc == 1) { + pattern = NULL; + } else if (objc == 2) { + pattern = TclGetString(objv[1]); + + /* + * Strip leading global-namespace qualifiers. [Bug 1057461] + */ + + if (pattern[0] == ':' && pattern[1] == ':') { + while (*pattern == ':') { + pattern++; + } + } + } else { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); + return TCL_ERROR; + } + + /* + * Scan through the global :: namespace's variable table and create a list + * of all global variables that match the pattern. + */ + + listPtr = Tcl_NewListObj(0, NULL); + if (pattern != NULL && TclMatchIsTrivial(pattern)) { + if (pattern == TclGetString(objv[1])) { + patternPtr = objv[1]; + } else { + patternPtr = Tcl_NewStringObj(pattern, -1); + } + Tcl_IncrRefCount(patternPtr); + + varPtr = VarHashFindVar(&globalNsPtr->varTable, patternPtr); + if (varPtr) { + if (!TclIsVarUndefined(varPtr)) { + Tcl_ListObjAppendElement(interp, listPtr, + VarHashGetKey(varPtr)); + } + } + Tcl_DecrRefCount(patternPtr); + } else { + for (varPtr = VarHashFirstVar(&globalNsPtr->varTable, &search); + varPtr != NULL; + varPtr = VarHashNextVar(&search)) { + if (TclIsVarUndefined(varPtr)) { + continue; + } + varNamePtr = VarHashGetKey(varPtr); + varName = TclGetString(varNamePtr); + if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, varNamePtr); + } + } + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclInfoLocalsCmd -- (moved over from tclCmdIl.c) + * + * Called to implement the "info locals" command to return a list of + * local variables that match an optional pattern. Handles the following + * syntax: + * + * info locals ?pattern? + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. + * + *---------------------------------------------------------------------- + */ + +int +TclInfoLocalsCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *CONST objv[]) /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Obj *patternPtr; + Tcl_Obj *listPtr; + + if (objc == 1) { + patternPtr = NULL; + } else if (objc == 2) { + patternPtr = objv[1]; + } else { + Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); + return TCL_ERROR; + } + + if (!(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC )) { + return TCL_OK; + } + + /* + * Return a list containing names of first the compiled locals (i.e. the + * ones stored in the call frame), then the variables in the local hash + * table (if one exists). + */ + + listPtr = Tcl_NewListObj(0, NULL); + AppendLocals(interp, listPtr, patternPtr, 0); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * AppendLocals -- + * + * Append the local variables for the current frame to the specified list + * object. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +AppendLocals( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *listPtr, /* List object to append names to. */ + Tcl_Obj *patternPtr, /* Pattern to match against. */ + int includeLinks) /* 1 if upvars should be included, else 0. */ +{ + Interp *iPtr = (Interp *) interp; + Var *varPtr; + int i, localVarCt; + Tcl_Obj **varNamePtr; + char *varName; + TclVarHashTable *localVarTablePtr; + Tcl_HashSearch search; + const char *pattern = patternPtr? TclGetString(patternPtr) : NULL; + Tcl_Obj *objNamePtr; + + localVarCt = iPtr->varFramePtr->numCompiledLocals; + varPtr = iPtr->varFramePtr->compiledLocals; + localVarTablePtr = iPtr->varFramePtr->varTablePtr; + varNamePtr = &iPtr->varFramePtr->localCachePtr->varName0; + + for (i = 0; i < localVarCt; i++, varNamePtr++) { + /* + * Skip nameless (temporary) variables and undefined variables. + */ + + if (*varNamePtr && !TclIsVarUndefined(varPtr) + && (includeLinks || !TclIsVarLink(varPtr))) { + varName = TclGetString(*varNamePtr); + if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); + } + } + varPtr++; + } + + /* + * Do nothing if no local variables. + */ + + if (localVarTablePtr == NULL) { + return; + } + + /* + * Check for the simple and fast case. + */ + + if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { + varPtr = VarHashFindVar(localVarTablePtr, patternPtr); + if (varPtr != NULL) { + if (!TclIsVarUndefined(varPtr) + && (includeLinks || !TclIsVarLink(varPtr))) { + Tcl_ListObjAppendElement(interp, listPtr, + VarHashGetKey(varPtr)); + } + } + return; + } + + /* + * Scan over and process all local variables. + */ + + for (varPtr = VarHashFirstVar(localVarTablePtr, &search); + varPtr != NULL; + varPtr = VarHashNextVar(&search)) { + if (!TclIsVarUndefined(varPtr) + && (includeLinks || !TclIsVarLink(varPtr))) { + objNamePtr = VarHashGetKey(varPtr); + varName = TclGetString(objNamePtr); + if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); + } + } + } +} + +/* + * Hash table implementation - first, just copy and adapt the obj key stuff + */ + +void +TclInitVarHashTable( + TclVarHashTable *tablePtr, + Namespace *nsPtr) +{ + Tcl_InitCustomHashTable(&tablePtr->table, + TCL_CUSTOM_TYPE_KEYS, &tclVarHashKeyType); + tablePtr->nsPtr = nsPtr; +} + +static Tcl_HashEntry * +AllocVarEntry( + Tcl_HashTable *tablePtr, /* Hash table. */ + VOID *keyPtr) /* Key to store in the hash table entry. */ +{ + Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; + Tcl_HashEntry *hPtr; + Var *varPtr; + + varPtr = (Var *) ckalloc(sizeof(VarInHash)); + varPtr->flags = VAR_IN_HASHTABLE; + varPtr->value.objPtr = NULL; + VarHashRefCount(varPtr) = 1; + + hPtr = &(((VarInHash *)varPtr)->entry); + Tcl_SetHashValue(hPtr, varPtr); + hPtr->key.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); + + return hPtr; +} + +static void +FreeVarEntry(Tcl_HashEntry *hPtr) +{ + Var *varPtr = VarHashGetValue(hPtr); + Tcl_Obj *objPtr = hPtr->key.objPtr; + + if (TclIsVarUndefined(varPtr) && !TclIsVarTraced(varPtr) + && (VarHashRefCount(varPtr) == 1)) { + ckfree((char *) varPtr); + } else { + VarHashInvalidateEntry(varPtr); + TclSetVarUndefined(varPtr); + VarHashRefCount(varPtr)--; + } + Tcl_DecrRefCount(objPtr); +} + +static int +CompareVarKeys( + VOID *keyPtr, /* New key to compare. */ + Tcl_HashEntry *hPtr) /* Existing key to compare. */ +{ + Tcl_Obj *objPtr1 = (Tcl_Obj *) keyPtr; + Tcl_Obj *objPtr2 = hPtr->key.objPtr; + register CONST char *p1, *p2; + register int l1, l2; + + /* + * If the object pointers are the same then they match. + */ + + if (objPtr1 == objPtr2) { + return 1; + } + + /* + * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being + * in a register. + */ + + p1 = TclGetString(objPtr1); + l1 = objPtr1->length; + p2 = TclGetString(objPtr2); + l2 = objPtr2->length; + + /* + * Only compare if the string representations are of the same length. + */ + + if (l1 == l2) { + for (;; p1++, p2++, l1--) { + if (*p1 != *p2) { + break; + } + if (l1 == 0) { + return 1; + } + } + } + + return 0; +} + +static unsigned int +HashVarKey( + Tcl_HashTable *tablePtr, /* Hash table. */ + VOID *keyPtr) /* Key from which to compute hash value. */ +{ + Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr; + CONST char *string = TclGetString(objPtr); + int length = objPtr->length; + unsigned int result = 0; + int i; + + /* + * I tried a zillion different hash functions and asked many other people + * for advice. Many people had their own favorite functions, all + * different, but no-one had much idea why they were good ones. I chose + * the one below (multiply by 9 and add new character) because of the + * following reasons: + * + * 1. Multiplying by 10 is perfect for keys that are decimal strings, and + * multiplying by 9 is just about as good. + * 2. Times-9 is (shift-left-3) plus (old). This means that each + * character's bits hang around in the low-order bits of the hash value + * for ever, plus they spread fairly rapidly up to the high-order bits + * to fill out the hash value. This seems works well both for decimal + * and *non-decimal strings. + */ + + for (i=0 ; i<length ; i++) { + result += (result << 3) + string[i]; + } + return result; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 |