Index: generic/tcl.decls ================================================================== --- generic/tcl.decls +++ generic/tcl.decls @@ -2323,10 +2323,30 @@ void Tcl_ZlibStreamSetCompressionDictionary(Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj) } # ----- BASELINE -- FOR -- 8.6.0 ----- # + +# TIP #XXX +declare 631 { + int Tcl_ArraySize(Tcl_Interp *interp, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, int flags) +} +declare 632 { + Tcl_ArraySearch Tcl_ArraySearchStart(Tcl_Interp *interp, + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags) +} +declare 633 { + Tcl_Obj *Tcl_ArraySearchNext(Tcl_ArraySearch search) +} +declare 634 { + void Tcl_ArraySearchDone(Tcl_ArraySearch search) +} +declare 635 { + int Tcl_ArrayNames(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + Tcl_Obj *listPtr, int flags) +} ############################################################################## # Define the platform specific public Tcl interface. These functions are only # available on the designated platform. Index: generic/tcl.h ================================================================== --- generic/tcl.h +++ generic/tcl.h @@ -530,10 +530,11 @@ #endif } #endif /* TCL_NO_DEPRECATED */ Tcl_Interp; +typedef struct Tcl_ArraySearch_ *Tcl_ArraySearch; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion; typedef struct Tcl_Command_ *Tcl_Command; typedef struct Tcl_Condition_ *Tcl_Condition; @@ -1084,10 +1085,11 @@ * Flag values passed to variable-related functions. * WARNING: these bit choices must not conflict with the bit choice for * TCL_CANCEL_UNWIND, above. */ +#define TCL_MATCH_EXACT 0 #define TCL_GLOBAL_ONLY 1 #define TCL_NAMESPACE_ONLY 2 #define TCL_APPEND_VALUE 4 #define TCL_LIST_ELEMENT 8 #define TCL_TRACE_READS 0x10 @@ -1094,15 +1096,17 @@ #define TCL_TRACE_WRITES 0x20 #define TCL_TRACE_UNSETS 0x40 #define TCL_TRACE_DESTROYED 0x80 #define TCL_INTERP_DESTROYED 0x100 #define TCL_LEAVE_ERR_MSG 0x200 +#define TCL_MATCH_GLOB 0x400 #define TCL_TRACE_ARRAY 0x800 #ifndef TCL_REMOVE_OBSOLETE_TRACES /* Required to support old variable/vdelete/vinfo traces. */ #define TCL_TRACE_OLD_STYLE 0x1000 #endif +#define TCL_MATCH_REGEXP 0x2000 /* Indicate the semantics of the result of a trace. */ #define TCL_TRACE_RESULT_DYNAMIC 0x8000 #define TCL_TRACE_RESULT_OBJECT 0x10000 /* Index: generic/tclDecls.h ================================================================== --- generic/tclDecls.h +++ generic/tclDecls.h @@ -1814,10 +1814,25 @@ Tcl_LoadHandle handlePtr); /* 630 */ EXTERN void Tcl_ZlibStreamSetCompressionDictionary( Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); +/* 631 */ +EXTERN int Tcl_ArraySize(Tcl_Interp *interp, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, int flags); +/* 632 */ +EXTERN Tcl_ArraySearch Tcl_ArraySearchStart(Tcl_Interp *interp, + Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, + int flags); +/* 633 */ +EXTERN Tcl_Obj * Tcl_ArraySearchNext(Tcl_ArraySearch search); +/* 634 */ +EXTERN void Tcl_ArraySearchDone(Tcl_ArraySearch search); +/* 635 */ +EXTERN int Tcl_ArrayNames(Tcl_Interp *interp, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, Tcl_Obj *listPtr, + int flags); typedef struct { const struct TclPlatStubs *tclPlatStubs; const struct TclIntStubs *tclIntStubs; const struct TclIntPlatStubs *tclIntPlatStubs; @@ -2480,10 +2495,15 @@ int (*tcl_NRSubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 626 */ int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */ void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */ int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */ void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */ + int (*tcl_ArraySize) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 631 */ + Tcl_ArraySearch (*tcl_ArraySearchStart) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 632 */ + Tcl_Obj * (*tcl_ArraySearchNext) (Tcl_ArraySearch search); /* 633 */ + void (*tcl_ArraySearchDone) (Tcl_ArraySearch search); /* 634 */ + int (*tcl_ArrayNames) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *listPtr, int flags); /* 635 */ } TclStubs; extern const TclStubs *tclStubsPtr; #ifdef __cplusplus @@ -3772,10 +3792,20 @@ (tclStubsPtr->tcl_FindSymbol) /* 628 */ #define Tcl_FSUnloadFile \ (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ #define Tcl_ZlibStreamSetCompressionDictionary \ (tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */ +#define Tcl_ArraySize \ + (tclStubsPtr->tcl_ArraySize) /* 631 */ +#define Tcl_ArraySearchStart \ + (tclStubsPtr->tcl_ArraySearchStart) /* 632 */ +#define Tcl_ArraySearchNext \ + (tclStubsPtr->tcl_ArraySearchNext) /* 633 */ +#define Tcl_ArraySearchDone \ + (tclStubsPtr->tcl_ArraySearchDone) /* 634 */ +#define Tcl_ArrayNames \ + (tclStubsPtr->tcl_ArrayNames) /* 635 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ Index: generic/tclStubInit.c ================================================================== --- generic/tclStubInit.c +++ generic/tclStubInit.c @@ -1414,8 +1414,13 @@ Tcl_NRSubstObj, /* 626 */ Tcl_LoadFile, /* 627 */ Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ + Tcl_ArraySize, /* 631 */ + Tcl_ArraySearchStart, /* 632 */ + Tcl_ArraySearchNext, /* 633 */ + Tcl_ArraySearchDone, /* 634 */ + Tcl_ArrayNames, /* 635 */ }; /* !END!: Do not edit above this line. */ Index: generic/tclVar.c ================================================================== --- generic/tclVar.c +++ generic/tclVar.c @@ -46,13 +46,21 @@ #define VarHashGetValue(hPtr) \ ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) /* - * NOTE: VarHashCreateVar increments the recount of its key argument. + * Bit mask matching any of the bits used to select a match filter. AND this + * mask against a flags value to obtain a value which can be compared against + * each of the available match modes using the "==" equality operator. + */ + +#define TCL_MATCH (TCL_MATCH_EXACT | TCL_MATCH_GLOB | TCL_MATCH_REGEXP) + +/* + * NOTE: VarHashCreateVar increments the refcount of its key argument. * All callers that will call Tcl_DecrRefCount on that argument must - * call Tcl_IncrRefCount on it before passing it in. This requirement + * call Tcl_IncrRefCount on it before passing it in. This requirement * can bubble up to callers of callers .... etc. */ static inline Var * VarHashCreateVar( @@ -143,32 +151,36 @@ #define HasLocalVars(framePtr) ((framePtr)->isProcCallFrame & FRAME_IS_PROC) /* * The following structure describes an enumerative search in progress on an - * array variable; this are invoked with options to the "array" command. + * array variable. It is used by Tcl_ArraySize(), Tcl_ArraySearchStart(), + * Tcl_ArraySearchNext(), Tcl_ArraySearchDone(), Tcl_ArrayNames(), and their + * respective [array] script interface commands. */ -typedef struct ArraySearch { +typedef struct Tcl_ArraySearch_ ArraySearch; +struct Tcl_ArraySearch_ { + Tcl_Interp *interp; /* Tcl interpreter in which search is run. */ Tcl_Obj *name; /* Name of this search */ int id; /* Integer id used to distinguish among * multiple concurrent searches for the same * array. */ - struct Var *varPtr; /* Pointer to array variable that's being + Var *varPtr; /* Pointer to array variable that's being * searched. */ Tcl_HashSearch search; /* Info kept by the hash module about progress * through the array. */ - Tcl_HashEntry *nextEntry; /* Non-null means this is the next element to - * be enumerated (it's leftover from the - * Tcl_FirstHashEntry call or from an "array - * anymore" command). NULL means must call - * Tcl_NextHashEntry to get value to - * return. */ - struct ArraySearch *nextPtr;/* Next in list of all active searches for + Var *nextEntry; /* Non-NULL means this is the next element to + * be enumerated (left over from ArrayFirst() + * or [array anymore]). NULL means must call + * ArrayNext() to get value to return. */ + ArraySearch *nextPtr; /* Next in list of all active searches for * this variable, or NULL if this is the last * one. */ -} ArraySearch; + Tcl_Obj *filterObj; /* Search filter pattern, or NULL if none. */ + int filterType; /* TCL_MATCH_EXACT, _GLOB, or _REGEXP. */ +}; /* * Forward references to functions defined later in this file: */ @@ -187,11 +199,19 @@ static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr, Tcl_Obj *varNamePtr, Tcl_Obj *handleObj); static void UnsetVarStruct(Var *varPtr, Var *arrayPtr, Interp *iPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags, int index); -static Var * VerifyArray(Tcl_Interp *interp, Tcl_Obj *varNameObj); +static Var * ArrayVar(Tcl_Interp *interp, Tcl_Obj *varNameObj, + int *traceFailPtr, int flags); +static Var * ArrayFirst(ArraySearch *searchPtr, int *failPtr); +static Var * ArrayNext(ArraySearch *searchPtr, int *failPtr); +static int ArraySize(Tcl_Interp *interp, Var *varPtr, + Tcl_Obj *filterObj, int filterType); +static int ArrayNames(Tcl_Interp *interp, Var *varPtr, + Tcl_Obj *filterObj, int filterType, + Tcl_Obj *listObj); /* * Functions defined in this file that may be exported in the future for use * by the bytecode compiler and engine or to the public interface. */ @@ -228,11 +248,10 @@ static const Tcl_ObjType tclParsedVarNameType = { "parsedVarName", FreeParsedVarName, DupParsedVarName, NULL, NULL }; - Var * TclVarHashCreateVar( TclVarHashTable *tablePtr, const char *key, @@ -915,11 +934,11 @@ * This function is used to locate a variable which is in an array's * hashtable given a pointer to the array's Var structure and the * element's name. * * Results: - * The return value is a pointer to the variable structure , or NULL if + * The return value is a pointer to the variable structure, or NULL if * the variable couldn't be found. * * If arrayPtr points to a variable that isn't an array and createPart1 * is 1, the corresponding variable will be converted to an array. * Otherwise, NULL is returned and an error message is left in the @@ -1042,10 +1061,624 @@ } } } return varPtr; } + +/* + *---------------------------------------------------------------------- + * + * ArrayVar -- + * + * This function looks up an existing array variable. + * + * Results: + * If successful, the requested variable is returned. On failure, NULL is + * returned, and error information is placed in the interpreter result. If + * the error occurred within an array trace and traceFailPtr is not NULL, + * *traceFailPtr is set to 1. Non-trace errors are inhibited if flags does + * not contain TCL_LEAVE_ERR_MSG. + * + * Side effects: + * Array traces, if any, are executed. + * + *---------------------------------------------------------------------- + */ + +static Var * +ArrayVar( + Tcl_Interp *interp, /* Command interpreter in which varNamePtr is to + * be looked up. */ + Tcl_Obj *varNameObj, /* Name of array variable in interp. */ + int *traceFailPtr, /* Unless NULL, set to 1 on trace failure. */ + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, and TCL_LEAVE_ERR_MSG. */ +{ + Var *varPtr, *arrayPtr; + const char *varName; + + /* + * Locate the array variable. + */ + + varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, + flags & ~TCL_LEAVE_ERR_MSG, /*msg*/ NULL, /*createPart1*/ 0, + /*createPart2*/ 0, &arrayPtr); + + /* + * Special array trace used to keep the env array in sync for array names, + * array get, etc. + */ + + if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + if (TclObjCallVarTraces((Interp *)interp, arrayPtr, varPtr, varNameObj, + NULL, flags | TCL_LEAVE_ERR_MSG | TCL_TRACE_ARRAY, + /*leaveErrMsg*/ 1, -1) == TCL_ERROR) { + if (traceFailPtr) { + *traceFailPtr = 1; + } + return NULL; + } + } + + /* + * Verify that it is indeed an array variable. This test comes after the + * traces - the variable may actually become an array as an effect of said + * traces. + */ + + if (!varPtr || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { + varName = TclGetString(varNameObj); + if (flags & TCL_LEAVE_ERR_MSG) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", varName)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL); + } + return NULL; + } + + /* + * On success, give the caller the address of the variable object. + */ + + return varPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayFirst -- + * + * Finds the first element of an array. If a filter is specified, only + * elements matching the filter are found. + * + * Preconditions: + * The interp, varPtr, filterObj, and filterType fields of *searchPtr must + * have been initialized. + * + * Results: + * The first array element is returned, or NULL if there are no matching + * elements or on error, in which case *failPtr is set to 1. + * + * Side effects: + * *searchPtr is updated to track the progress of the enumeration. On + * error, detailed error information is placed into the interpreter result. + * + *---------------------------------------------------------------------- + */ + +static Var * +ArrayFirst( + ArraySearch *searchPtr, /* Array enumeration state structure. */ + int *failPtr) /* Set to 1 on error. */ +{ + TclVarHashTable *tablePtr = searchPtr->varPtr->value.tablePtr; + Var *varPtr; + + /* + * Exact matches and trivial glob matches can be completed immediately since + * they will only ever match one or zero elements. No need to iterate, just + * do a direct lookup, then fast-forward to the end of the hash table. + */ + + if (searchPtr->filterObj + && (searchPtr->filterType == TCL_MATCH_EXACT + || (searchPtr->filterType == TCL_MATCH_GLOB + && TclMatchIsTrivial(TclGetString(searchPtr->filterObj))))) { + varPtr = VarHashFindVar(tablePtr, searchPtr->filterObj); + searchPtr->search.tablePtr = &tablePtr->table; + searchPtr->search.nextIndex = tablePtr->table.numBuckets; + searchPtr->search.nextEntryPtr = NULL; + searchPtr->nextEntry = NULL; + + if (!varPtr || TclIsVarUndefined(varPtr)) { + return NULL; + } else { + return varPtr; + } + } + + /* + * For all other match types, find the first item (which may or may not + * match the filter) then chain to ArrayNext() to get the real first item. + */ + + searchPtr->nextEntry = VarHashFirstVar(tablePtr, &searchPtr->search); + return ArrayNext(searchPtr, failPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ArrayNext -- + * + * Finds the next element of an array for a given search query. + * + * Preconditions: + * ArrayFirst() must have been called on searchPtr. + * + * Results: + * The next array element is returned, or NULL if there are no matching + * elements remaining or on error, in which case *failPtr is set to 1 if + * failPtr is not NULL. + * + * Side effects: + * *searchPtr is updated to track the progress of the enumeration. On + * error, detailed error information is placed into the interpreter result. + * + *---------------------------------------------------------------------- + */ + +static Var * +ArrayNext( + ArraySearch *searchPtr, /* Array enumeration state structure. */ + int *failPtr) /* Set to 1 on error. */ +{ + Var *varPtr; + Tcl_Obj *nameObj; + int matched; + + /* + * Use the cached nextEntry left over from ArrayFirst() or [array anymore], + * or else get the next one from the hash table. + */ + + if (searchPtr->nextEntry) { + varPtr = searchPtr->nextEntry; + searchPtr->nextEntry = NULL; + } else { + varPtr = VarHashNextVar(&searchPtr->search); + } + + /* + * Iterate through the hash table until an element matches the filter or the + * end is reached. + */ + + for (; varPtr; varPtr = VarHashNextVar(&searchPtr->search)) { + if (!TclIsVarUndefined(varPtr)) { + /* + * If no filter, accept each defined element regardless of name. + */ + + if (!searchPtr->filterObj) { + return varPtr; + } + + /* + * Conditionally accept elements whose names match the filter. + */ + + nameObj = VarHashGetKey(varPtr); + if (searchPtr->filterType == TCL_MATCH_GLOB) { + if (Tcl_StringMatch(TclGetString(nameObj), + TclGetString(searchPtr->filterObj))) { + return varPtr; + } + } else if (searchPtr->filterType == TCL_MATCH_REGEXP) { + matched = Tcl_RegExpMatchObj(searchPtr->interp, nameObj, + searchPtr->filterObj); + if (matched < 0) { + if (failPtr) { + *failPtr = 1; + } + return NULL; + } else if (matched) { + return varPtr; + } + } else if (searchPtr->filterType == TCL_MATCH_EXACT) { + Tcl_Panic("exact matching shouldn't get here"); + } else { + Tcl_Panic("invalid filter type: %u", searchPtr->filterType); + } + } + } + + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * ArraySize -- + * + * This function returns the number of elements in an array variable. + * + * Results: + * The return value is the integer count of array elements. The only + * possible error is a regular expression error, in which case -1 is + * returned and the error information is loaded into the interp result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ArraySize( + Tcl_Interp *interp, /* Interpreter, used to report regexp errors. */ + Var *varPtr, /* Array variable. */ + Tcl_Obj *filterObj, /* Element filter or NULL to accept all. */ + int filterType) /* TCL_MATCH_EXACT, _GLOB, or _REGEXP. */ +{ + ArraySearch search; + int fail = 0, size = 0; + + /* + * Count the number of times ArrayFirst() or ArrayNext() returns non-NULL. + */ + + search.interp = interp; + search.varPtr = varPtr; + search.filterObj = filterObj; + search.filterType = filterType; + search.nextEntry = NULL; + varPtr = ArrayFirst(&search, &fail); + for (; varPtr; varPtr = ArrayNext(&search, &fail)) { + ++size; + } + + /* + * Return -1 on error or the number of matching elements on success. + */ + + if (fail) { + return -1; + } else { + return size; + } +} + +/* + *---------------------------------------------------------------------- + * + * ArrayNames -- + * + * Obtains a list of array element names, optionally limited by a filter. + * + * Results: + * Normally, TCL_OK is returned, and the list of matching array element + * names is appended to listObj. On error, TCL_ERROR is returned, and the + * error information is placed in the interpreter's result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ArrayNames( + Tcl_Interp *interp, /* Interpreter, used to report regexp errors. */ + Var *varPtr, /* Array variable. */ + Tcl_Obj *filterObj, /* Element filter or NULL to accept all. */ + int filterType, /* TCL_MATCH_EXACT, _GLOB, or _REGEXP. */ + Tcl_Obj *listObj) /* List to which array names are appended. */ +{ + ArraySearch search; + int fail = 0, oldLen, newLen; + + /* + * Ensure output object is a list. Also get its length in case there is + * trouble and changes need to be rolled back. Such a failure should never + * occur because it requires a regular expression to initially succeed then + * return error on a subsequent evaluation, but handle it anyway because + * it's easy to do. + */ + + if (Tcl_ListObjLength(interp, listObj, &oldLen) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Begin the search. + */ + + search.interp = interp; + search.varPtr = varPtr; + search.filterObj = filterObj; + search.filterType = filterType; + search.nextEntry = NULL; + varPtr = ArrayFirst(&search, &fail); + + /* + * Enumerate the array. + */ + + for (; varPtr; varPtr = ArrayNext(&search, &fail)) { + Tcl_ListObjAppendElement(interp, listObj, VarHashGetKey(varPtr)); + } + + /* + * On failure, roll back changes to output list. + */ + + if (fail) { + Tcl_ListObjLength(interp, listObj, &newLen); + Tcl_ListObjReplace(interp, listObj, oldLen, newLen - oldLen, 0, NULL); + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArraySize -- + * + * This function returns the number of elements in an array variable. It + * provides C-level access to [array size] functionality, except this + * function does not treat scalar and nonexistent variable as if they were + * empty arrays. If part2Ptr is not NULL, only array elements whose names + * match part2Ptr are counted toward the return value. The interpretation + * of part2Ptr is controlled by TCL_MATCH_* being set within flags. + * + * Results: + * The return value is normally the integer count of array elements whose + * names match the given filter. If varNamePtr does not name an array, -1 + * is returned and an error message is placed in interp's result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ArraySize( + Tcl_Interp *interp, /* Command interpreter in which part1Ptr is to + * be looked up. */ + Tcl_Obj *part1Ptr, /* Name of array variable in interp. */ + Tcl_Obj *part2Ptr, /* Element filter or NULL to accept all. */ + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, and TCL_LEAVE_ERR_MSG, + * also at most one of TCL_MATCH_EXACT, _GLOB, + * and _REGEXP. */ +{ + Var *varPtr = ArrayVar(interp, part1Ptr, NULL, flags); + return varPtr ? ArraySize(interp, varPtr, part2Ptr, flags & TCL_MATCH) : -1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArraySearchStart -- + * + * This function initiates an array search, i.e. step-by-step array element + * enumeration. It provides C-level access to [array startsearch]. The + * returned value is used to obtain one array element name at a time. If + * part2Ptr is not NULL, only array elements whose names match part2Ptr are + * returned by future calls to Tcl_ArraySearchNext(). The interpretation of + * part2Ptr is controlled by TCL_MATCH_* being set within flags. + * + * Results: + * A new array search is created, a pointer to which is returned. If the + * variable does not exist or is not an array, NULL is returned, and no + * search is created. + * + * Side effects: + * On success, the search is allocated on the heap and will need to be + * deallocated by a future call to Tcl_ArraySearchDone(). + * + *---------------------------------------------------------------------- + */ + +Tcl_ArraySearch +Tcl_ArraySearchStart( + Tcl_Interp *interp, /* Command interpreter in which part1Ptr is to + * be looked up. */ + Tcl_Obj *part1Ptr, /* Name of array variable in interp. */ + Tcl_Obj *part2Ptr, /* Element filter or NULL to accept all. */ + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, and TCL_LEAVE_ERR_MSG, + * also at most one of TCL_MATCH_EXACT, _GLOB, + * and _REGEXP. */ +{ + Interp *iPtr = (Interp *)interp; + Var *varPtr = ArrayVar(interp, part1Ptr, NULL, flags); + Tcl_HashEntry *hPtr; + int isNew, fail = 0; + ArraySearch search, *searchPtr; + + /* + * Handle the possible error cases before performing any allocations. + */ + + if (!varPtr) { + return NULL; + } + + search.interp = interp; + search.varPtr = varPtr; + search.filterObj = part2Ptr; + search.filterType = flags & TCL_MATCH; + search.nextEntry = ArrayFirst(&search, &fail); + if (!search.nextEntry && fail) { + return NULL; + } + + /* + * Make a new array search with a free name. + */ + + hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew); + if (isNew) { + search.id = 1; + varPtr->flags |= VAR_SEARCH_ACTIVE; + search.nextPtr = NULL; + } else { + search.id = ((ArraySearch *)Tcl_GetHashValue(hPtr))->id + 1; + search.nextPtr = Tcl_GetHashValue(hPtr); + } + search.name = Tcl_ObjPrintf("s-%d-%s", search.id, TclGetString(part1Ptr)); + Tcl_IncrRefCount(search.name); + if (part2Ptr) { + Tcl_IncrRefCount(part2Ptr); + } + searchPtr = ckalloc(sizeof(*searchPtr)); + *searchPtr = search; + Tcl_SetHashValue(hPtr, searchPtr); + + return searchPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArraySearchNext -- + * + * Finds the next element of an array for a given search query. + * + * Preconditions: + * The search argument must be the return value of Tcl_ArraySearchStart() + * and must not have been passed to Tcl_ArraySearchDone(). + * + * Results: + * The return value is the name of the next array element. If there are no + * more array elements, NULL is returned. + * + * Side effects: + * The search data structure is updated such that successive invocations of + * this function will return successive array element names. + * + * Limitations: + * It is not possible to distinguish between reaching the end of the array + * and experiencing a regular expression error. This is unlikely to be an + * actual problem because Tcl_ArraySearchStart() already checks for regular + * expression errors and returns NULL if found. If the regular expression + * engine has a bug whereby a given query can initially succeed yet return + * error depending on the string it is matched against, the caller of this + * function will perceive it as prematurely hitting the end of the array. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_ArraySearchNext( + Tcl_ArraySearch search) /* Prior return from Tcl_ArraySearchStart(). */ +{ + Var *varPtr = ArrayNext(search, NULL); + return varPtr ? VarHashGetKey(varPtr) : NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArraySearchDone -- + * + * Terminates and cleans up an array search query. + * + * Preconditions: + * The search argument must be the return value of Tcl_ArraySearchStart() + * and must not have been passed to Tcl_ArraySearchDone(). + * + * Results: + * The search query is completed. + * + * Side effects: + * Resources associated with the search are deallocated. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ArraySearchDone( + Tcl_ArraySearch search) /* Prior return from Tcl_ArraySearchStart(). */ +{ + Interp *iPtr = (Interp *)search->interp; + Var *varPtr = search->varPtr; + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr); + ArraySearch *prevPtr; + + /* + * Unhook the search from the list of searches associated with the + * variable. + */ + + if (search == Tcl_GetHashValue(hPtr)) { + if (search->nextPtr) { + Tcl_SetHashValue(hPtr, search->nextPtr); + } else { + varPtr->flags &= ~VAR_SEARCH_ACTIVE; + Tcl_DeleteHashEntry(hPtr); + } + } else { + for (prevPtr = Tcl_GetHashValue(hPtr);; prevPtr = prevPtr->nextPtr) { + if (prevPtr->nextPtr == search) { + prevPtr->nextPtr = search->nextPtr; + break; + } + } + } + Tcl_DecrRefCount(search->name); + if (search->filterObj) { + Tcl_DecrRefCount(search->filterObj); + } + ckfree(search); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ArrayNames -- + * + * Obtains a list of array element names, optionally limited by a filter. + * + * Results: + * Normally, TCL_OK is returned, and the list of matching array element + * names is appended to listObj. On error, TCL_ERROR is returned, and the + * error information is placed in the interpreter's result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ArrayNames( + Tcl_Interp *interp, /* Command interpreter in which part1Ptr is to + * be looked up. */ + Tcl_Obj *part1Ptr, /* Name of array variable in interp. */ + Tcl_Obj *part2Ptr, /* Element filter or NULL to accept all. */ + Tcl_Obj *listPtr, /* List to which array names are appended. */ + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, and TCL_LEAVE_ERR_MSG, + * also at most one of TCL_MATCH_EXACT, _GLOB, + * and _REGEXP. */ +{ + Var *varPtr = ArrayVar(interp, part1Ptr, NULL, flags); + + if (varPtr) { + return ArrayNames(interp, varPtr, part2Ptr, flags & TCL_MATCH, listPtr); + } else { + return TCL_ERROR; + } +} /* *---------------------------------------------------------------------- * * Tcl_GetVar -- @@ -2845,100 +3478,29 @@ * *---------------------------------------------------------------------- */ /* ARGSUSED */ - -static Var * -VerifyArray( - Tcl_Interp *interp, - Tcl_Obj *varNameObj) -{ - Interp *iPtr = (Interp *) interp; - const char *varName = TclGetString(varNameObj); - Var *arrayPtr; - - /* - * Locate the array variable. - */ - - Var *varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return NULL; - } - } - - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", varName)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL); - return NULL; - } - - return varPtr; -} - static int ArrayStartSearchCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr; - Tcl_HashEntry *hPtr; - int isNew; ArraySearch *searchPtr; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); return TCL_ERROR; } - varPtr = VerifyArray(interp, objv[1]); - if (varPtr == NULL) { + searchPtr = Tcl_ArraySearchStart(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); + if (!searchPtr) { return TCL_ERROR; } - /* - * Make a new array search with a free name. - */ - - searchPtr = ckalloc(sizeof(ArraySearch)); - hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew); - if (isNew) { - searchPtr->id = 1; - varPtr->flags |= VAR_SEARCH_ACTIVE; - searchPtr->nextPtr = NULL; - } else { - searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1; - searchPtr->nextPtr = Tcl_GetHashValue(hPtr); - } - searchPtr->varPtr = varPtr; - searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, - &searchPtr->search); - Tcl_SetHashValue(hPtr, searchPtr); - searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, TclGetString(objv[1])); - Tcl_IncrRefCount(searchPtr->name); Tcl_SetObjResult(interp, searchPtr->name); return TCL_OK; } /* @@ -2967,22 +3529,21 @@ Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; Var *varPtr; Tcl_Obj *varNameObj, *searchObj; - int gotValue; ArraySearch *searchPtr; + int gotValue, fail = 0; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); return TCL_ERROR; } varNameObj = objv[1]; searchObj = objv[2]; - varPtr = VerifyArray(interp, varNameObj); - if (varPtr == NULL) { + if (!(varPtr = ArrayVar(interp, varNameObj, NULL, TCL_LEAVE_ERR_MSG))) { return TCL_ERROR; } /* * Get the search. @@ -2992,28 +3553,23 @@ if (searchPtr == NULL) { return TCL_ERROR; } /* - * Scan forward to find if there are any further elements in the array - * that are defined. + * Scan forward to find if there are any further matching elements in the + * array. Put the found element (if any) into searchPtr->nextEntry so that + * it is not consumed and is available for the next call. */ - while (1) { - if (searchPtr->nextEntry != NULL) { - varPtr = VarHashGetValue(searchPtr->nextEntry); - if (!TclIsVarUndefined(varPtr)) { - gotValue = 1; - break; - } - } - searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search); - if (searchPtr->nextEntry == NULL) { - gotValue = 0; - break; - } - } + if ((searchPtr->nextEntry = ArrayNext(searchPtr, &fail))) { + gotValue = 1; + } else if (fail) { + return TCL_ERROR; + } else { + gotValue = 0; + } + Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[gotValue]); return TCL_OK; } /* @@ -3041,22 +3597,21 @@ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Var *varPtr; - Tcl_Obj *varNameObj, *searchObj; + Tcl_Obj *varNameObj, *searchObj, *resultObj; ArraySearch *searchPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); return TCL_ERROR; } varNameObj = objv[1]; searchObj = objv[2]; - varPtr = VerifyArray(interp, varNameObj); - if (varPtr == NULL) { + if (!(varPtr = ArrayVar(interp, varNameObj, NULL, TCL_LEAVE_ERR_MSG))) { return TCL_ERROR; } /* * Get the search. @@ -3067,32 +3622,18 @@ return TCL_ERROR; } /* * Get the next element from the search, or the empty string on - * exhaustion. Note that the [array anymore] command may well have already - * pulled a value from the hash enumeration, so we have to check the cache - * there first. + * exhaustion. */ - while (1) { - Tcl_HashEntry *hPtr = searchPtr->nextEntry; - - if (hPtr == NULL) { - hPtr = Tcl_NextHashEntry(&searchPtr->search); - if (hPtr == NULL) { - return TCL_OK; - } - } else { - searchPtr->nextEntry = NULL; - } - varPtr = VarHashGetValue(hPtr); - if (!TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, VarHashGetKey(varPtr)); - return TCL_OK; - } - } + if ((resultObj = Tcl_ArraySearchNext(searchPtr))) { + Tcl_SetObjResult(interp, resultObj); + } + + return TCL_OK; } /* *---------------------------------------------------------------------- * @@ -3117,25 +3658,22 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; Var *varPtr; - Tcl_HashEntry *hPtr; Tcl_Obj *varNameObj, *searchObj; - ArraySearch *searchPtr, *prevPtr; + ArraySearch *searchPtr; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName searchId"); return TCL_ERROR; } varNameObj = objv[1]; searchObj = objv[2]; - varPtr = VerifyArray(interp, varNameObj); - if (varPtr == NULL) { + if (!(varPtr = ArrayVar(interp, varNameObj, NULL, TCL_LEAVE_ERR_MSG))) { return TCL_ERROR; } /* * Get the search. @@ -3149,28 +3687,11 @@ /* * Unhook the search from the list of searches associated with the * variable. */ - hPtr = Tcl_FindHashEntry(&iPtr->varSearches, 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=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) { - if (prevPtr->nextPtr == searchPtr) { - prevPtr->nextPtr = searchPtr->nextPtr; - break; - } - } - } - Tcl_DecrRefCount(searchPtr->name); - ckfree(searchPtr); + Tcl_ArraySearchDone(searchPtr); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -3196,13 +3717,13 @@ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; + Var *varPtr; Tcl_Obj *arrayNameObj; - int notArray; + int traceFail = 0, isArray; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); return TCL_ERROR; } @@ -3210,34 +3731,20 @@ /* * Locate the array variable. */ - varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, arrayNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } - } - - /* - * Check whether we've actually got an array variable. - */ - - notArray = ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)); - Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[!notArray]); + varPtr = ArrayVar(interp, arrayNameObj, &traceFail, 0); + if (varPtr) { + isArray = 1; + } else if (traceFail) { + return TCL_ERROR; + } else { + isArray = 0; + } + + Tcl_SetObjResult(interp, iPtr->execEnvPtr->constants[isArray]); return TCL_OK; } /* *---------------------------------------------------------------------- @@ -3262,17 +3769,16 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr, *varPtr2; + Var *varPtr, *varPtr2; Tcl_Obj *varNameObj, *nameObj, *valueObj, *nameLstObj, *tmpResObj; Tcl_Obj **nameObjPtr, *patternObj; Tcl_HashSearch search; const char *pattern; - int i, count, result; + int traceFail = 0, i, count, result; switch (objc) { case 2: varNameObj = objv[1]; patternObj = NULL; @@ -3288,36 +3794,23 @@ /* * Locate the array variable. */ - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + varPtr = ArrayVar(interp, varNameObj, &traceFail, 0); /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. + * Report trace failures as errors. If the variable is a scalar or does not + * exist, treat it like an empty array. */ - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { + if (!varPtr) { + if (traceFail) { return TCL_ERROR; - } - } - - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. If not an array, it's an empty result. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - return TCL_OK; + } else { + return TCL_OK; + } } pattern = (patternObj ? TclGetString(patternObj) : NULL); /* @@ -3449,46 +3942,25 @@ Tcl_Obj *const objv[]) { static const char *const options[] = { "-exact", "-glob", "-regexp", NULL }; + static const int flags[] = { + TCL_MATCH_EXACT, TCL_MATCH_GLOB, TCL_MATCH_REGEXP + }; enum options { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr, *varPtr2; - Tcl_Obj *varNameObj, *nameObj, *resultObj, *patternObj; - Tcl_HashSearch search; - const char *pattern = NULL; - int mode = OPT_GLOB; + Tcl_Obj *varNameObj, *resultObj, *patternObj; + Var *varPtr; + int traceFail = 0, mode = OPT_GLOB; if ((objc < 2) || (objc > 4)) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?mode? ?pattern?"); return TCL_ERROR; } varNameObj = objv[1]; patternObj = (objc > 2 ? objv[objc-1] : NULL); - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } - } - /* * Finish parsing the arguments. */ if ((objc == 4) && Tcl_GetIndexFromObj(interp, objv[2], options, "option", @@ -3495,77 +3967,32 @@ 0, &mode) != TCL_OK) { return TCL_ERROR; } /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. If not an array, the result is empty. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - return TCL_OK; - } - - /* - * Check for the trivial cases where we can use a direct lookup. - */ - - TclNewObj(resultObj); - if (patternObj) { - pattern = TclGetString(patternObj); - } - if ((mode==OPT_GLOB && patternObj && TclMatchIsTrivial(pattern)) - || (mode==OPT_EXACT)) { - varPtr2 = VarHashFindVar(varPtr->value.tablePtr, patternObj); - if ((varPtr2 != NULL) && !TclIsVarUndefined(varPtr2)) { - /* - * This can't fail; lappending to an empty object always works. - */ - - Tcl_ListObjAppendElement(NULL, resultObj, VarHashGetKey(varPtr2)); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; - } - - /* - * Must scan the array to select the elements. - */ - - for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search); - varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { - if (TclIsVarUndefined(varPtr2)) { - continue; - } - nameObj = VarHashGetKey(varPtr2); - if (patternObj) { - const char *name = TclGetString(nameObj); - int matched = 0; - - switch ((enum options) mode) { - case OPT_EXACT: - Tcl_Panic("exact matching shouldn't get here"); - case OPT_GLOB: - matched = Tcl_StringMatch(name, pattern); - break; - case OPT_REGEXP: - matched = Tcl_RegExpMatchObj(interp, nameObj, patternObj); - if (matched < 0) { - TclDecrRefCount(resultObj); - return TCL_ERROR; - } - break; - } - if (matched == 0) { - continue; - } - } - - Tcl_ListObjAppendElement(NULL, resultObj, nameObj); - } + * Find the variable. Report trace failures as errors. If the variable is a + * scalar or does not exist, treat it like an empty array. + */ + + if (!(varPtr = ArrayVar(interp, varNameObj, &traceFail, 0))) { + if (!traceFail) { + return TCL_OK; + } else { + return TCL_ERROR; + } + } + + /* + * Generate the result list. + */ + + resultObj = Tcl_NewObj(); + if (ArrayNames(interp, varPtr, patternObj, flags[mode], + resultObj) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, resultObj); return TCL_OK; } /* @@ -3638,37 +4065,24 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; + int traceFail = 0; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName list"); return TCL_ERROR; } - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, objv[1], NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - /* * Special array trace used to keep the env array in sync for array names, * array get, etc. */ - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, objv[1], NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } + if (!ArrayVar(interp, objv[1], &traceFail, 0) && traceFail) { + return TCL_ERROR; } return TclArraySet(interp, objv[1], objv[2]); } @@ -3695,62 +4109,32 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; - Tcl_Obj *varNameObj; - Tcl_HashSearch search; - Var *varPtr2; - int size = 0; + Var *varPtr; + int traceFail = 0, size; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); return TCL_ERROR; } - varNameObj = objv[1]; - - /* - * Locate the array variable. - */ - - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } - } - - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. We can only iterate over the array if it exists... - */ - - if (varPtr && TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { - /* - * Must iterate in order to get chance to check for present but - * "undefined" entries. - */ - - for (varPtr2=VarHashFirstVar(varPtr->value.tablePtr, &search); - varPtr2!=NULL ; varPtr2=VarHashNextVar(&search)) { - if (!TclIsVarUndefined(varPtr2)) { - size++; - } - } + + /* + * Unlike Tcl_ArraySize(), the [array size] command treats nonexistent and + * non-array variables as having zero size. The only errors [array size] can + * report are argument count (handled above) and array trace (handled here). + */ + + varPtr = ArrayVar(interp, objv[1], &traceFail, 0); + + if (varPtr) { + size = ArraySize(interp, varPtr, NULL, 0); + } else if (!traceFail) { + size = 0; + } else { + return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(size)); return TCL_OK; } @@ -3779,14 +4163,14 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr; + Var *varPtr; Tcl_Obj *varNameObj; char *stats; + int traceFail = 0; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); return TCL_ERROR; } @@ -3794,39 +4178,12 @@ /* * Locate the array variable. */ - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return TCL_ERROR; - } - } - - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "\"%s\" isn't an array", TclGetString(varNameObj))); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", - TclGetString(varNameObj), NULL); + varPtr = ArrayVar(interp, varNameObj, &traceFail, TCL_LEAVE_ERR_MSG); + if (!varPtr) { return TCL_ERROR; } stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr); if (stats == NULL) { @@ -3862,15 +4219,15 @@ ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *) interp; - Var *varPtr, *arrayPtr, *varPtr2, *protectedVarPtr; + Var *varPtr, *varPtr2, *protectedVarPtr; Tcl_Obj *varNameObj, *patternObj, *nameObj; Tcl_HashSearch search; const char *pattern; + int traceFail = 0; const int unsetFlags = 0; /* Should this be TCL_LEAVE_ERR_MSG? */ switch (objc) { case 2: varNameObj = objv[1]; @@ -3887,36 +4244,18 @@ /* * Locate the array variable */ - varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, - /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); - - /* - * Special array trace used to keep the env array in sync for array names, - * array get, etc. - */ - - if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { - if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, - (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| - TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { + varPtr = ArrayVar(interp, varNameObj, &traceFail, 0); + + if (!varPtr) { + if (traceFail) { return TCL_ERROR; - } - } - - /* - * Verify that it is indeed an array variable. This test comes after the - * traces - the variable may actually become an array as an effect of said - * traces. - */ - - if ((varPtr == NULL) || !TclIsVarArray(varPtr) - || TclIsVarUndefined(varPtr)) { - return TCL_OK; + } else { + return TCL_OK; + } } if (!patternObj) { /* * When no pattern is given, just unset the whole array.